Path finding Visualizer
Table of Contents
Description
This is a OCaml script implementing, and visualizing the result and calculation of some path finding algorithms like Dijkstra's and A*. It also have different distance approximations and path optimizing methods.
News
- 19 Aug 2010: v 1.1. Shows all tiles in cloud (not just the first 10).
- 31 Jul 2010: Fixed Linux binary download link, added usage information.
- 30 Jul 2010: Page creation.
Files
I couldn't figure out how to compile the OCaml Curses bindings on Windows, so no Windows binary.
- Linux binary: pathvisual v 1.1, 19 Aug 2010
- Source: pathvisual_1.1.tar.gz v 1.1, 19 Aug 2010
- Source: pathvisual_1.0.tar.gz v 1.0, 30 Jul 2010
Usage
-
Linux binary:
- Must be run from a terminnal
-
chmod +x pathvisual -
./pathvisual
-
Compiling on Ubuntu
-
tar xzvf pathvisual_1.1.tar.gz -
cd pathvisual -
sudo apt-get install ocaml libcurses-ocaml libcurses-ocaml-dev(libcurses-ocaml is in universe) -
make -
./pathvisual
-
Features
-
Cave-like territory, implemented from roguebasin.roguelikedevelopment.org
- Also a slow implementation of a properly connected cave (several seconds to generate).
-
Path finding algorithms
- Dijkstra's Algorithm
- A*
- Greedy A*. Like A* but only looks at current location's neighbours
-
Distance approximation
- Proper Pythagorean
- Approximation |x1 - x2| + |y1 - y2|
-
Path finding algorithm visualization
- Show tiles being considered at each step.
-
Path optimizer, clean up/optimize a path.
- Good.
- Fast. After a path optimization, continue with path point after the optimized part.
-
Path optimizer visualization
- Show each line-of-sight being considered and if it hits a wall.
Screenshots
This is a path generated using A*, with the optimal distance algorithm and no path optimization.
This is the same as in the previous screenshot, but in the middle of a
path finding visualization. The + are tiles already visited. 0 is
the next tile to be considered (for A* this means the tile with the
lowest ("cost from source" + "estimated distance to destination")),
the other numbers are the next 9 tiles to be considered.
This shows the A* Greedy path finding algorithm in the middle of a
path optimization visualization. The O's are the points on the path
being checked for possible optimization. The + is the line between
the points. And the | is where a wall was found (meaning these 2
points can't be optimized).
Why
I wanted to fool around with path finding but had a hard time getting the algorithms working or working fast enough. The solution was adding more and more debugging information, which finally resulted in a visualizer. Also, ML is fun.
Ocamldoc
Code
I put it all in one big file for no-ones convenience.
(** Path Visualizer 1.1 Version 1.1 19 Aug 2010: Show all tiles in cloud as "9"s (before it only showed 10 (from "0" to "9")) @since 2010-07-29 @author Dan Amlund Thomsen <danamlund.gmail.com> www.danamlund.dk *) module IntPairHash = (struct (** Hashtbl mapping from [int * int]. *) (** {!module: Hashtbl.S} of [int * int]. *) include (Hashtbl.Make (struct type t = int * int let hash = Hashtbl.hash let equal = (=) end)) (** Check if [elt] exists in [hash]. *) let exists hash elt = try find hash elt; true with _ -> false (** Convert a [IntPairHash] to a list of [(key,value)] tuples. *) let to_list hash = fold (fun k v xs -> (k,v) :: xs) hash [] end) module MutBinHeap = (struct (** Mutable binary heap of [(int * int) * int * float] using hash table for fast delete *) type pos = int * int type elt = pos * int * float type arrayidx = int type t = { mutable last : arrayidx; mutable arr : elt array; hash : arrayidx IntPairHash.t; compare : (elt -> elt -> int) } let get heap (idx : arrayidx) = if idx >= heap.last then raise Not_found else Array.get heap.arr idx (** Get array index of parent *) let parent (i : arrayidx) : arrayidx = i/2 (** Get array index of left child *) let left_child (i : arrayidx) : arrayidx = i*2 (** Get array index of right child *) let right_child (i : arrayidx) : arrayidx = i*2+1 (** Get element with given pos *) let getpos heap pos = get heap (IntPairHash.find heap.hash pos) (** Swaps 2 array indexes *) let swap heap i j = let ielt = get heap i in let jelt = get heap j in Array.set heap.arr i jelt; Array.set heap.arr j ielt; (match ielt with (ipos,_,_) -> IntPairHash.replace heap.hash ipos j); match jelt with (jpos,_,_) -> IntPairHash.replace heap.hash jpos i let rec bubbleup heap idx = try let parent = (parent idx) in if heap.compare (get heap idx) (get heap parent) < 0 then (swap heap idx parent; bubbleup heap parent) else () with | _ -> () let rec bubbledown heap idx = try if heap.compare (get heap idx) (get heap (left_child idx)) > 0 then (swap heap idx (left_child idx); bubbledown heap (left_child idx)) else if heap.compare (get heap idx) (get heap (right_child idx)) > 0 then (swap heap idx (right_child idx); bubbledown heap (right_child idx)) else () with | _ -> () (** Make a new binary heap. {[make (fun ((x,y),cost,dist) ((x',y'),cost',dist') -> compare ((float cost) +. dist) ((float cost') +. dist'))]} makes a binary heap comparing cost + distance (A* ) *) let make compare = {last = 0; arr = Array.make 100 ((0,0),0,0.0); hash = IntPairHash.create 100; compare = compare} (** Insert element into heap *) let insert heap elt = (if heap.last >= Array.length heap.arr then (let arr' = heap.arr in heap.arr <- Array.make (heap.last*2) elt; Array.blit arr' 0 heap.arr 0 heap.last)); Array.set heap.arr heap.last elt; (match elt with (pos,_,_) -> IntPairHash.replace heap.hash pos heap.last); heap.last <- heap.last+1; bubbleup heap (heap.last-1) (** Remove element {[((x,y),cost,dist)]} where {[(x,y) = pos]} *) let remove heap pos = try let idx = IntPairHash.find heap.hash pos in swap heap idx (heap.last-1); heap.last <- heap.last-1; ignore (bubbleup heap idx); ignore (bubbledown heap idx); IntPairHash.remove heap.hash pos with | _ -> () (** Insert new element or replace existing element with matching first. {[replace heap ((2,0),2,3.0)]} would replace the existing element {[((2,0),3,5.0)]}. *) let replace heap elt = match elt with (pos,_,_) -> remove heap pos; insert heap elt (** Returns the minimum element and removes it from the heap. *) let pop heap = let root = get heap 0 in (match root with (pos,_,_) -> remove heap pos); root end) module Geometry = (struct (** Geometric functions. *) (** Bresenham's line algorithm *) let rec line (x,y) (x',y') = if abs (y'-y) > abs (x'-x) then List.map (fun (y,x) -> (x,y)) (line (y,x) (y',x')) else if x > x' then List.rev (line (x',y') (x,y)) else let dx = x' - x in let dy = abs (y' - y) in let error = dx / 2 in let ystep = (if y < y' then 1 else -1) in let rec loop curx cury error = if curx > x' then [] else let error' = error - dy in if error' < 0 then (curx,cury) :: loop (curx+1) (cury+ystep) (error'+dx) else (curx,cury) :: loop (curx+1) cury error' in loop x y error end) module IntPairSet = (struct (** Set over [int * int] *) (** {!module: Set.S} of [int * int]. *) include Set.Make (struct type t = int * int let compare = compare end) let of_list list = List.fold_right (fun x xs -> add x xs) list empty exception Exception of int * int end) module Cave = (struct (** Functions to create and modify caves. *) type wall_types = WALL | FLOOR type t = wall_types array array (** Make a new cave of dimensions initialized to consist of [WALL]s *) let make x y : t = Array.make_matrix x y WALL (** Make a new cave initialized to [init] *) let makeinit x y init : t = Array.make_matrix x y init (** Iterate over cave elements. {[iter (fun w -> print_string (string_of_wall w)) (fun () -> print_newline ()) cave]} will print cave *) let iter f f' (cave : t) = Array.iter (fun xs -> Array.iter f xs; f' ()) cave let map f (cave : t) = Array.map (fun xs -> Array.map f xs) cave let copy (cave : t) : t = let cave1' = Array.copy cave in Array.iteri (fun i xs -> Array.set cave1' i (Array.copy xs)) cave; cave1' let set (cave : t) x y elt = Array.set cave.(y) x elt let fold_right f f' (cave : t) i = Array.fold_right (fun xs rest -> f' (Array.fold_right f xs i) rest) cave i let mapi f (cave : t) = Array.mapi (fun y xs -> Array.mapi (fun x w -> f x y w) xs) cave let string_of_wall w = match w with | WALL -> "#" | FLOOR -> "." let string_of_cave cave = fold_right (fun w rest -> (string_of_wall w) ^ rest) (fun a b -> a ^ "\n" ^ b) cave "" let print cave = print_string (string_of_cave cave) let get (cave : t) x y = try cave.(y).(x) with | Invalid_argument s -> WALL let is_valid_coor (cave : t) x y = try ignore (cave.(y).(x)); true with | _ -> false let wall_neighbours cave x y = List.fold_right (fun x rest -> match x with | WALL -> 1 + rest | _ -> rest) [ get cave (x-1) (y-1); get cave x (y-1); get cave (x+1) (y-1); get cave (x-1) y; get cave x y; get cave (x+1) y; get cave (x-1) (y+1); get cave x (y+1); get cave (x+1) (y+1) ] 0 let caveify cave n : t = mapi (fun x y w -> if wall_neighbours cave x y >= n then WALL else FLOOR) cave let neighbour_coords' (x,y) = [ x,(y-1) ; (x-1),y; (x+1),y; x,(y+1); ] let neighbour_coords (x,y) = [ (x-1),(y-1); x,(y-1); (x+1),(y-1); (x-1),y; (x+1),y; (x-1),(y+1); x,(y+1); (x+1),(y+1) ] let inrangexy (cave : t) x y = x >= 0 && y >= 0 && x < Array.length cave && y < Array.length cave.(0) let isfloor cave x y = get cave x y = FLOOR let rec getvalidxy cave = let x = Random.int (Array.length cave) in let y = Random.int (Array.length cave.(0)) in if get cave x y != WALL then (x,y) else getvalidxy cave let intpairset_neighbours cave set = IntPairSet.diff (IntPairSet.fold (fun (x,y) tosearch -> List.fold_right (fun (x,y) tosearch' -> if not (inrangexy cave x y) then tosearch' else IntPairSet.add (x,y) tosearch') (neighbour_coords (x,y)) tosearch) set set) set let rec connected cave seen = let rec loop seen = let seen' = (IntPairSet.filter (fun (x,y) -> get cave x y != WALL) (intpairset_neighbours cave seen)) in if IntPairSet.is_empty seen' then seen else loop (IntPairSet.union seen seen') in loop seen let find_unconnected cave seen = let rec loop (searched, tosearch) = if IntPairSet.is_empty tosearch then raise Not_found else (IntPairSet.iter (fun (x,y) -> if get cave x y = FLOOR && not (IntPairSet.exists (fun z -> z = (x,y)) seen) then raise (IntPairSet.Exception (x,y))) tosearch; let searched' = IntPairSet.union searched tosearch in loop (searched', intpairset_neighbours cave searched')) in try loop (seen, intpairset_neighbours cave seen) with | IntPairSet.Exception (x,y) -> (x,y) | Not_found -> raise Not_found let find_connected cave (x,y) connected = let rec loop seen = let seen' = intpairset_neighbours cave seen in if IntPairSet.is_empty seen' then raise Not_found else (IntPairSet.iter (fun (x,y) -> (if (IntPairSet.exists (fun z -> z = (x,y)) connected) then raise (IntPairSet.Exception (x,y)))) seen; loop (IntPairSet.union seen seen')) in try loop (IntPairSet.add (x,y) IntPairSet.empty) with | IntPairSet.Exception (x,y) -> (x,y) let dig_tunnel cave (x,y) (x',y') = let cave' = copy cave in List.iter (fun (x,y) -> set cave' x y FLOOR) (Geometry.line (x,y) (x',y')); cave' let rec connect_cave' cave (x,y) seen = try let unconnected = find_unconnected cave seen in let closest_connected = find_connected cave unconnected seen in let cave' = dig_tunnel cave unconnected closest_connected in connect_cave' cave' unconnected (connected cave' seen) with Not_found -> cave let connect_cave cave = let xy = getvalidxy cave in connect_cave' cave xy (connected cave (IntPairSet.add xy IntPairSet.empty)) let makecave1 x y p = map (fun x -> if (Random.int 100) < p then WALL else FLOOR) (make x y) let makecave2 x y = caveify (caveify (caveify (map (fun x -> if (Random.int 100) < 45 then WALL else FLOOR) (make x y)) 5) 5) 5 let makecave3 x y = connect_cave (makecave2 x y) let cave0 = [|[|FLOOR;FLOOR;FLOOR;FLOOR|]; [|FLOOR;WALL;WALL;FLOOR|]; [|FLOOR;WALL;WALL;FLOOR|]; [|FLOOR;FLOOR;FLOOR;FLOOR|]|] let cave1 = [|[|FLOOR;WALL;FLOOR;FLOOR;WALL;FLOOR|]; [|FLOOR;WALL;WALL;WALL;WALL;FLOOR|]; [|FLOOR;WALL;FLOOR;FLOOR;WALL;FLOOR|]; [|WALL;WALL;FLOOR;FLOOR;WALL;FLOOR|]; [|FLOOR;WALL;WALL;WALL;WALL;FLOOR|]; [|FLOOR;FLOOR;FLOOR;FLOOR;FLOOR;FLOOR|];|] let cave2 = [|[|FLOOR;FLOOR;FLOOR;FLOOR|]; [|FLOOR;FLOOR;FLOOR;FLOOR|]; [|FLOOR;FLOOR;FLOOR;FLOOR|]; [|FLOOR;FLOOR;FLOOR;FLOOR|]|] end) module PathFinding = (struct (** Pathfinding functions. *) type pos = int * int type path = pos list type hash_from_pos_to_int = int IntPairHash.t type heap_of_pos_cost_dist = MutBinHeap.t type distance_function = pos -> pos -> float let dist_simple ((x,y) : pos) ((x',y') : pos) = float ((abs (x-x')) + (abs (y-y'))) let dist_euclid ((x,y) : pos) ((x',y') : pos) = sqrt ((float (x-x') ** 2.0) +. (float (y-y') ** 2.0)) let rec string_of_path (path : path) = match path with | ((x,y) :: path') -> "(" ^ (string_of_int x) ^ "," ^ (string_of_int y) ^ ") " ^ string_of_path path' | [] -> "\n" let path (src : pos) (dst : pos) (visited : hash_from_pos_to_int) : path = let rec lowercost xs cost = match xs with | (x :: xs') -> if try IntPairHash.find visited x < cost with _ -> false then x else lowercost xs' cost | [] -> raise Not_found and loop x = try if x = src then [src] else (loop (lowercost (Cave.neighbour_coords x) (IntPairHash.find visited x))) @ [x] with _ -> [] in loop dst let lineofsight (src : pos) (dst : pos) (f : pos -> bool) = let rec loop xs = match xs with | (x :: xs') -> if f x then loop xs' else false | [] -> true in loop (Geometry.line src dst) let path_opt'' cave ((seen : path), (notseen : path), (tocheck : path), havechecked) foundf = match notseen with | (xy :: notseen') -> (match tocheck with | (xy2 :: tocheck') -> if lineofsight xy xy2 (fun (x,y) -> Cave.get cave x y != Cave.WALL) then foundf seen notseen havechecked xy xy2 else (seen, notseen, tocheck', xy2 :: havechecked) | [] -> (seen @ [xy], notseen', List.rev notseen', [])) | [] -> (seen, notseen, tocheck, havechecked) let path_opt' cave path = ([], path, List.rev (List.tl path), []) let path_opt cave path foundf = let rec loop (seen, notseen, tocheck, havechecked) = match notseen with | [] -> seen | _ -> loop (path_opt'' cave (seen, notseen, tocheck, havechecked) foundf) in loop (path_opt' cave path) let path_opt_good_foundf seen notseen havechecked xy xy2 = let notseen'' = List.tl ((Geometry.line xy xy2) @ havechecked) in (seen @ [xy], notseen'', List.rev notseen'', []) let path_opt_good cave path = path_opt cave path path_opt_good_foundf let path_opt_fast_foundf seen notseen havechecked xy xy2 = (seen @ (Geometry.line xy xy2), havechecked, List.rev havechecked, []) let path_opt_fast cave path = path_opt cave path path_opt_fast_foundf exception Exception_intpairhash of int IntPairHash.t let pathfindingloop cave src dst f' f'' dist = let rec loop (visited, waiting) = try loop (f'' cave dst visited waiting dist) with | Exception_intpairhash visited -> visited | _ -> IntPairHash.create 1 in path src dst (loop (f' cave src dst)) let astar'' cave dst (visited : hash_from_pos_to_int) (waiting : heap_of_pos_cost_dist) (dist : distance_function) = let (src,cost,_) = MutBinHeap.pop waiting in IntPairHash.replace visited src cost; if src = dst then raise (Exception_intpairhash visited) else ((List.iter (fun (x,y) -> if Cave.get cave x y != Cave.WALL && not (IntPairHash.exists visited (x,y)) && (try let (_,cost',_) = MutBinHeap.getpos waiting (x,y) in cost < cost' with _ -> true) then (MutBinHeap.replace waiting ((x,y), cost+1, dist (x,y) dst))) (Cave.neighbour_coords src)); (visited, waiting)) let astar' cave src dst = let waiting = (MutBinHeap.make (fun (_,ac,ah) (_,bc,bh) -> compare ((float ac) +. ah) ((float bc) +. bh))) in MutBinHeap.replace waiting (src, 0, max_float); (IntPairHash.create 100, waiting) let astar cave src dst dist = pathfindingloop cave src dst astar' astar'' dist let rec dijkstra'' = astar'' let dijkstra' cave src dst = let waiting = (MutBinHeap.make (fun (_,ac,ah) (_,bc,bh) -> compare ac bc)) in MutBinHeap.replace waiting (src, 0, max_float); (IntPairHash.create 100, waiting) let dijkstra cave src dst dist = pathfindingloop cave src dst dijkstra' dijkstra'' dist let greedy_astar'' = astar'' let greedy_astar' cave src dst = let waiting = (MutBinHeap.make (fun (_,ac,ah) (_,bc,bh) -> compare ah bh)) in MutBinHeap.replace waiting (src, 0, max_float); (IntPairHash.create 100, waiting) let greedy_astar cave src dst dist = pathfindingloop cave src dst greedy_astar' greedy_astar'' dist end) module UI = (struct (** Interface in Curses for visualizing pathfinding functions in caves. *) type pos = int * int type state = { mutable window : Curses.window; mutable window_cave : Curses.window; mutable cave : (Cave.wall_types array array); mutable cursor : pos; mutable src : pos; mutable dst : pos; mutable path : (int * int) list; mutable alg : int; mutable auto_path : bool; mutable dist_alg : int; mutable path_opt_alg : int; mutable map_type : int; mutable cave_x : int; mutable cave_y : int} let printf = Printf.printf let sprintf = Printf.sprintf let string_of_char = String.make 1 let getch' n = try match n with | 260 -> "left" | 261 -> "right" | 259 -> "up" | 258 -> "down" | 10 | 343 -> "enter" | 331 -> "0" | 360 -> "1" | 338 -> "3" | 339 -> "9" | 262 -> "7" | n -> string_of_char (char_of_int n) with _ -> "unknown" let getch () = getch' (Curses.getch ()) let get_pathfinding n = match n with | 0 -> PathFinding.dijkstra | 1 -> PathFinding.astar | _ -> PathFinding.greedy_astar let get_pathfinding_name n = match n with | 0 -> "Dijkstra" | 1 -> "A*" | _ -> "A* Greedy" let get_dist_alg n = match n with | 0 -> PathFinding.dist_simple | _ -> PathFinding.dist_euclid let get_dist_alg_name n = match n with | 0 -> "|x1 - x2| + |y1 - y2|" | _ -> "sqrt((x1-x2)^2+(y1-y2)^2)" let get_path_opt_alg n = match n with | 0 -> (fun _ x -> x) | 1 -> PathFinding.path_opt_good | _ -> PathFinding.path_opt_fast let get_path_opt_alg_name n = match n with | 0 -> "None" | 1 -> "Good" | _ -> "Fast" let get_map_type n = match n with | 0 -> Cave.makecave2 | _ -> Cave.makecave3 let get_map_type_name n = match n with | 0 -> "Cave" | _ -> "Connected cave (SLOW)" let printcave window cave = ignore (Curses.move 0 0); Cave.iter (fun w -> ignore (Curses.waddstr window (Cave.string_of_wall w))) (fun () -> ignore (Curses.waddstr window "\n")) cave let set_cursor_ifvalid s (x,y) = if Cave.isfloor s.cave x y then s.cursor <- (x,y) let waddstr window x y str = ignore (Curses.wmove window y x); ignore (Curses.waddstr window str); () let refresh s = ignore (Curses.wmove s.window 0 0); ignore (Curses.wmove s.window_cave 0 0); ignore (Curses.wrefresh s.window); ignore (Curses.wrefresh s.window_cave) let draw_path s = let rec loop path = match path with | ((x,y) :: path') -> waddstr s.window_cave x y "x"; loop path' | [] -> () in loop s.path; match s.src with (src_x,src_y) -> match s.dst with (dst_x,dst_y) -> waddstr s.window_cave src_x src_y "S"; waddstr s.window_cave dst_x dst_y "D" let my_draw s = Curses.werase s.window; waddstr s.window 0 0 ("------------------------ Pathfinding Visualizer "^ "------------------------"); waddstr s.window 40 1 "s: Set source"; waddstr s.window 40 2 "z: Algorithm visualization"; waddstr s.window 40 3 "x: Path optimizer visualization"; waddstr s.window 40 4 (sprintf "p: %s automatic pathfinding " (if s.auto_path then "Disable" else "Enable")); waddstr s.window 40 5 "enter: New map"; waddstr s.window 40 6 "q: Quit"; waddstr s.window 0 1 (sprintf "(a)lg: %s" (get_pathfinding_name s.alg)); waddstr s.window 0 2 (sprintf "(d)ist: %s" (get_dist_alg_name s.dist_alg)); waddstr s.window 0 3 (sprintf "path (o)pt: %s" (get_path_opt_alg_name s.path_opt_alg)); waddstr s.window 0 4 (sprintf "(m)ap: %s" (get_map_type_name s.map_type)); printcave s.window_cave s.cave; draw_path s; match s.cursor with (x,y) -> waddstr s.window_cave x y "@"; refresh s let debug_path_legend s = waddstr s.window 40 1 "q: stop visualization "; waddstr s.window 40 2 "Legend: "; waddstr s.window 40 3 "+: Already looked at "; waddstr s.window 40 4 "0-9: Cloud (0 next in line) "; waddstr s.window 40 5 " "; waddstr s.window 40 6 " " let debug_path s = let (f,f') = (match s.alg with | 0 -> (PathFinding.dijkstra', PathFinding.dijkstra'') | 1 -> (PathFinding.astar', PathFinding.astar'') | _ -> (PathFinding.greedy_astar', PathFinding.greedy_astar'')) in let dist = get_dist_alg s.dist_alg in let rec loop (visited, waiting) = try let print_num waiting n = try (let ((x,y),_,_) = MutBinHeap.get waiting n in waddstr s.window_cave x y (sprintf "%i" n)) with | _ -> () in let print_cloud waiting = let rec loop n = if n >= waiting.MutBinHeap.last then () else ((match MutBinHeap.get waiting n with ((x,y),_,_) -> waddstr s.window_cave x y "9"); loop (n+1)) in loop 0 in my_draw s; debug_path_legend s; print_cloud waiting; print_num waiting 8; print_num waiting 7; print_num waiting 6; print_num waiting 5; print_num waiting 4; print_num waiting 3; print_num waiting 2; print_num waiting 1; print_num waiting 0; IntPairHash.iter (fun (x,y) v -> waddstr s.window_cave x y "+") visited; refresh s; match getch () with | "q" -> () | _ -> loop (f' s.cave s.dst visited waiting dist) with | PathFinding.Exception_intpairhash visited -> s.path <- (PathFinding.path s.src s.dst visited) in loop (f s.cave s.src s.dst) let set_path s = s.path <- ((get_path_opt_alg s.path_opt_alg) s.cave ((get_pathfinding s.alg s.cave) s.src s.dst (get_dist_alg s.dist_alg))) let debug_opt_legend s = waddstr s.window 40 1 "q: stop visualization "; waddstr s.window 40 2 "Legend: "; waddstr s.window 40 3 "+: Line-check "; waddstr s.window 40 4 "|: wall found in line-check "; waddstr s.window 40 5 "O: start/end of line-check "; waddstr s.window 40 6 " " let debug_opt s = let (f'', foundf) = (match s.path_opt_alg with | 0 -> ((fun _ (x,_,_,_) _ -> (x,[],[],[])), fun _ _ _ _ _ -> ([],[],[],[])) | 1 -> (PathFinding.path_opt'', PathFinding.path_opt_good_foundf) | _ -> (PathFinding.path_opt'', PathFinding.path_opt_fast_foundf)) in let rec loop (seen, notseen, tocheck, havechecked) = match notseen with | [] -> () | _ -> let drawline window src dst = List.iter (fun (x,y) -> waddstr window x y "+") (Geometry.line src dst); ignore (PathFinding.lineofsight src dst (fun (x,y) -> if Cave.get s.cave x y != Cave.WALL then (waddstr window x y "+"; true) else (waddstr window x y "|"; false))); () in s.path <- seen @ (List.rev notseen); my_draw s; debug_opt_legend s; (try drawline s.window_cave (List.hd notseen) (List.hd tocheck); (match (List.hd tocheck) with | (x,y) -> waddstr s.window_cave x y "O"); (match (List.hd notseen) with | (x,y) -> waddstr s.window_cave x y "O") with _ -> ()); refresh s; match getch () with | "q" -> () | _ -> loop (f'' s.cave (seen, notseen, tocheck, havechecked) foundf) in let old_path_opt_alg = s.path_opt_alg in s.path_opt_alg <- 0; set_path s; loop (PathFinding.path_opt' s.cave s.path); s.path_opt_alg <- old_path_opt_alg; set_path s let new_map s = s.cave <- get_map_type s.map_type s.cave_y s.cave_x; s.cursor <- Cave.getvalidxy s.cave; s.src <- s.cursor; s.dst <- s.cursor; s.path <- [] let rec loop s = s.dst <- s.cursor; (if s.auto_path then set_path s); my_draw s; match getch () with | "q" -> printf "Quit.\n" | "enter" -> new_map s; loop s | "up" | "8" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x, y-1)); loop s | "9" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x+1, y-1)); loop s | "right" | "6" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x+1, y)); loop s | "3" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x+1, y+1)); loop s | "down" | "2" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x, y+1)); loop s | "1" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x-1, y+1)); loop s | "left" | "4" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x-1, y)); loop s | "7" -> (match s.cursor with (x,y) -> set_cursor_ifvalid s (x-1, y-1)); loop s | "s" -> s.src <- s.cursor; loop s | "a" -> s.alg <- (s.alg+1) mod 3; loop s | "z" -> debug_path s; loop s | "x" -> debug_opt s; loop s | "p" -> s.auto_path <- not s.auto_path; s.path <- []; loop s | "d" -> s.dist_alg <- (s.dist_alg+1) mod 2; loop s | "o" -> s.path_opt_alg <- (s.path_opt_alg+1) mod 3; loop s | "m" -> s.map_type <- (s.map_type+1) mod 2; loop s | _ -> loop s let main () = let cave_x = ref 75 in let cave_y = ref 30 in Arg.parse [("-x", Arg.Set_int cave_x, "width of cave"); ("-y", Arg.Set_int cave_y, "height of cave")] (fun _ -> ()) "Usage: pathvisual [options]"; let window = Curses.initscr () in let window_top = Curses.newwin 7 75 0 0 in let window_cave = Curses.newwin (!cave_y+3) (!cave_x+3) 7 0 in Random.self_init (); at_exit Curses.endwin; ignore (Curses.noecho ()); ignore (Curses.keypad window true); let cave = Cave.makecave2 !cave_y !cave_x in let xy = Cave.getvalidxy cave in let s = {window = window_top; window_cave = window_cave; cave = cave; cursor = xy; src = xy; dst = xy; path = []; alg = 0; auto_path = true; dist_alg = 0; path_opt_alg = 0; map_type = 0; cave_x = !cave_x; cave_y = !cave_y} in ignore (Curses.refresh ()); loop s let curses_keys () = let window = Curses.initscr () in at_exit Curses.endwin; ignore (Curses.noecho ()); ignore (Curses.keypad window true); let rec loop () = ignore (Curses.wmove window 0 0); let ch = Curses.getch () in ignore (Curses.waddstr window (sprintf "input: %i name: %s " ch (getch' ch))); loop () in loop () end)
Comments
Date: 2010-08-19 13:54:06 CEST
HTML generated by org-mode 6.36trans in emacs 23