Using dictionaries, graphs, and lists, I'm attempting to implement the Dijkstra algorithm with BFS in Clojure. The issue is that I can't get it to work correctly; it won't work when I ask it to return the solution with weights, and it also won't work when I ask it to produce the graph without weights.
The problem occurs, most likely, at the BFS function; I would very appreciate any assistance with this.
I tried to search for information online and spoke with some of my classmates, but unfortunately it didn't help at all.
The files: e-roads-2020-full.clj + project.clj are in GitHub https://github.com/wfgemyd/clojure
;; state 0 - not encountered at all
;; state 1 - in the open queue
;; state 2 - current vertex
;; state 3 - visited
(defn al-papi [queue graph] ;;looks for the best vertex and dist
(loop [queue queue
best-distance nil
best-vertex nil]
(if (empty? queue)
best-vertex
(let [queue-label (first queue)
queue-vertex (get #(:vertices graph) queue-label)]
(if (or (nil? best-vertex) (< #(:distance queue-vertex) best-distance))
(recur (rest queue) #(:distance queue-vertex) queue-vertex)
(recur (rest queue) best-distance best-vertex))))))
(defn graph-bfs!
([graph]
(graph-bfs! graph (first (keys #(:vertices graph)))))
([graph start]
(graph-bfs! graph start (fn [vertex] nil)))
([graph start func]
(graph-bfs! graph start func first))
([graph start func func-m]
(let [vertices #(:vertices graph)]
(loop [queue (list start)]
(when (not (empty? queue))
(let [current-label (if (= func-m al-papi)(func-m queue graph)(func-m queue))
rest-queue (rest-queue! queue current-label)
current-vertex (get vertices current-label)
visited-status (:visited current-vertex)
current-neighbors #(:neighbors current-vertex)
unseen-neighbors (filter
(fn [label]
(= #(:visited (get vertices label)) 0))
current-neighbors)
]
(dosync (ref-set visited-status 2))
(func current-vertex)
(dosync (ref-set visited-status 3))
(doseq [label unseen-neighbors]
(dosync
(ref-set (:visited (get vertices label)) 1)))
(recur (concat rest-queue unseen-neighbors))))))))
(defn graph-dijkstra-mark! [graph finish use-weights]
(let [vertices #(:vertices graph)
start-vertex (get vertices finish)]
(graph-reset! graph)
(dosync
(ref-set (:distance start-vertex) 0))
(if (not use-weights)
(graph-bfs! graph
finish
(fn [vertex]
(let [next-distance (inc #(:distance vertex))]
(doseq [neighbor-label #(:neighbors vertex)]
(let [neighbor (get vertices neighbor-label)]
(if (= #(:visited neighbor) 0)
(dosync
(ref-set (:distance neighbor) next-distance))))))))
(graph-bfs! graph
finish
(fn [vertex]
(doseq [neighbor-label #(:neighbors vertex)]
(let [neighbor (get vertices neighbor-label)
next-distance (+ #(:distance vertex) (get-edge-weight graph (:label vertex) neighbor-label))]
(println "There is bfs!")
(when (or (= #(:visited neighbor) 0) (> #(:distance neighbor) next-distance))
(dosync
(ref-set (:distance neighbor) next-distance))))))
al-papi))))
Found the bug, it was in the back trace function, it was returning the ref and not the actual data that was needed in the function, plus the function "al-papi" was returning the best-vertex and not the :label of the best-vertex.
Related
How would we go about implementing get the shortest path between the start vertex and the end vertex?
The program should return a list of edges (shortest path) using BFS.
(define (new-paths path node net)
(map (lambda (n) (cons n path)) (cdr (assoc node net))))
(define (shortest-path start end net)
(bfs end (list (list start)) net))
;; Breadth-first search
(define (bfs end queue net)
(display queue) (newline) (newline) ; entertainment
(if (null? queue)
'()
(let ((path (car queue)))
(let ((node (car path)))
(if (equal? node end) ;; Graham used CL eql
(reverse path)
(bfs end
(append (cdr queue)
(new-paths path node net))
net))))))
I came up with but this does not seem to work. Can someone provide an implementation in a purely functional way?
In the form (get-shortest-path vertices edges src dest)
An example of the call would be
(get-shortest-path '(a b c d) (cons (cons a b) (cons b c) (cons c d)) 'a 'c)
; Get the shortest path between a and c
I have been stuck on this question for days. Apparently I need to write a better algorithm to win the algorithm below. The below code is implemented from the famous Aima file. Is there any expert here who could guide me on how to win the algorithm?
(defun find-closest (list)
(x (car (array-dimensions list)))
(y (cadr (array-dimensions list)))
(let ((elems (aref list x y)))
(dolist (e elems)
(when (eq (type-of e) type)
(return-from find-closest (list x y)))) nil))
I tried implementing a DFS but failed and I do not quite know why. Below is my code.
(defun find-closest (list)
(let ((open (list list))
(closed (list))
(steps 0)
(expanded 0)
(stored 0))
(loop while open do
(let ((x (pop open)))
(when (finished? x)
(return (format nil "Found ~a in ~a steps.
Expanded ~a nodes, stored a maximum of ~a nodes." x steps expanded stored)))
(incf steps)
(pushnew x closed :test #'equal)
(let ((successors (successors x)))
(incf expanded (length successors))
(setq successors
(delete-if (lambda (a)
(or (find a open :test #'equal)
(find a closed :test #'equal)))
successors))
(setq open (append open successors))
(setq stored (max stored (length open))))))))
Looking at the code, the function find-some-in-grid returns the first found thing of type. This will, essentially, give you O(n * m) time for an n * m world (imagine a world, where you have one dirt on each line, alternating between "left-most" and "right-most".
Since you can pull out a list of all dirt locations, you can build a shortest traversal, or at least a shorter-than-dump traversal, by instead of picking whatever dirt you happen to find first you pick the closest (for some distance metric, from the code it looks like you have Manhattan distances (that is, you can only move along the X xor the Y axis, not both at the same time). That should give you a robot that is at least as good as the dumb-traversal robot and frequently better, even if it's not optimal.
With the provision that I do NOT have the book and base implementation purely on what's in your question, something like this might work:
(defun find-closest-in-grid (radar type pos-x pos-y)
(labels ((distance (x y)
(+ (abs (- x pos-x))
(abs (- y pos-y)))))
(destructuring-bind (width height)
(array-dimensions radar)
(let ((best nil)
((best-distance (+ width height))))
(loop for x from 0 below width
do (loop for y from 0 below height
do (loop for element in (aref radar x y)
do (when (eql (type-of element) type)
(when (<= (distance x y) best-distance)
(setf best (list x y))
(setf best-distance (distance x y))))))))
best)))
I have no problem in implementing this algorithm in any imperative language, but I am struggling implementing it in Clojure or any other functional language. A lot of algorithms are described in terms of working with mutable data structures and imperative loops and it is hard for me to translate all of those to a functional domain.
Here is my incomplete attempt (a draft, not a working implementation) at implementing it in Clojure using adjacency lists as graph representation:
(ns karger.core
(:require [clojure.string :as string]))
(defn load-data []
(zipmap
(range 1 1000)
(map rest (map read-string
(string/split (slurp "data.txt") #"\n")))))
(defn min-cut [graph]
(let [start (rand-int (count graph))
end (rand-int (graph start))
start-list (nth graph start)]
(for [x (graph end)
:when (not= x start)]
(assoc graph start (conj start-list x)))
))
(count (load-data))
Can anyone give me a reference implementation of this algorithm (preferably written in Clojure)? Also I would like if someone gave me a general advice of translating an algorithm described in imperative terms to a functional domain.
Thanks in advance!
UPDATE #1
Here is a link to algorithm implementation written in Python: http://pastebin.com/WwWCtxpu
There are fundamental problems with your code as is:
your start-list binding is a number and cannot be conjed to'
you are calling assoc and ignoring the return value, thus making it a no-op.
you are using for as if it were a looping construct (it is a list comprehension)
you are calling nth on a hash-map, which will always fail (zipmap returns a hash-map)
In general the idea in functional programming is to lift mutable variables into immutable local bindings by making the "state of the world" entirely encapsulated by the function arguments, and making function calls with refined versions of that state.
Here is a working implementation from scratch based on the python solution you posted, and the graph file used by the java example here
(ns min-cut.core
(:require [clojure.java.io :as io]
[clojure.string :as string]
[clojure.pprint :refer [pprint]]))
(defn make-maps
[filename]
(reduce (fn [graph line]
(let [[node & edges] (->> line
(#(string/split % #"\W+"))
(remove #{""})
(map read-string))]
(assoc graph node (set edges))))
{}
(line-seq (io/reader filename))))
(defn karger
[graph]
(if (<= (count (keys graph))
2)
(count (graph (apply min (keys graph))))
(let [start (rand-nth (keys graph))
finish (rand-nth (vec (graph start)))
graph (loop [g graph
[edge & edges] (seq (graph finish))]
(if-not edge
g
(recur
(if (= edge start)
g
(update-in g [start] conj edge))
edges)))
graph (loop [g graph
[edge & edges] (seq (graph finish))]
(if-not edge
g
(let [gr (update-in g [edge] disj finish)
gr (if (= edge start)
gr
(update-in gr [edge] conj start))]
(recur gr edges))))
graph (dissoc graph finish)]
(recur graph))))
(defn -main
[& [file]]
(let [file (or file "kargerAdj.txt")
graph (make-maps file)]
(println "min cut is: "
(reduce min (repeatedly 1801 #(karger graph))))))
This is a very literal translation of the python code, so there are multiple places this code could be improved. For starters the two loops in the karger function could likely be replaced by a single reduce which would be much more concise and clear.
Note that no value that is created in this code is ever mutated - values are rebound but none of the incoming data structures are changed, and the only global definitions used are the functions make-maps, karger, and -main - all data is locally bound and passed to the next user.
I wrote the code below for game I am working on. But it seems a little slow. If you have not checked the code yet, it's the A* search/pathfinding algorithm. It takes about 100-600 ms for a 100x100 grid, depending on the heuristic used (and consequently the number of tiles visited).
There are no reflection warnings. However, I suspect boxing might be an issue. But I don't know how to get rid of boxing in this case, because the computation is split among several functions. Also, I save tiles/coordinates as vectors of two numbers, like this: [x y]. But then the numbers will be boxed, right? A typical piece of code, if you don't want to read through it all, is: (def add-pos (partial mapv + pos)) where pos is the aforementioned kind of two-number vector. There are sereval of places where the numbers are manipulated in a way similar to add-pos above, and put back in a vector afterwards. Is there any way to optimize code like this? Any other tips is welcome too, performance-related or other.
EDIT: Thinking some more about it, I came up with a few follow-up questions: Can a Clojure function ever return primitives? Can a Clojure function ever take primitives (without any boxing)? Can I put primitives in a type/record without boxing?
(ns game.server.pathfinding
(:use game.utils)
(:require [clojure.math.numeric-tower :as math]
[game.math :as gmath]
[clojure.data.priority-map :as pm]))
(defn walkable? [x]
(and x (= 1 x)))
(defn point->tile
([p] (apply point->tile p))
([x y] [(int x) (int y)]))
(defn get-tile [m v]
"Gets the type of the tile at the point v in
the grid m. v is a point in R^2, not grid indices."
(get-in m (point->tile v)))
(defn integer-points
"Given an equation: x = start + t * step, returns a list of the
values for t that make x an integer between start and stop,
or nil if there is no such value for t."
[start stop step]
(if-not (zero? step)
(let [first-t (-> start ((if (neg? step) math/floor math/ceil))
(- start) (/ step))
t-step (/ 1 (math/abs step))]
(take-while #((if (neg? step) > <) (+ start (* step %)) stop)
(iterate (partial + t-step) first-t)))))
(defn crossed-tiles [[x y :as p] p2 m]
(let [[dx dy :as diff-vec] (map - p2 p)
ipf (fn [getter]
(integer-points (getter p) (getter p2) (getter diff-vec)))
x-int-ps (ipf first)
y-int-ps (ipf second)
get-tiles (fn [[x-indent y-indent] t]
(->> [(+ x-indent x (* t dx)) (+ y-indent y (* t dy))]
(get-tile m)))]
(concat (map (partial get-tiles [0.5 0]) x-int-ps)
(map (partial get-tiles [0 0.5]) y-int-ps))))
(defn clear-line?
"Returns true if the line between p and p2 passes over only
walkable? tiles in m, otherwise false."
[p p2 m]
(every? walkable? (crossed-tiles p p2 m)))
(defn clear-path?
"Returns true if a circular object with radius r can move
between p and p2, passing over only walkable? tiles in m,
otherwise false.
Note: Does not currently work for objects with a radius >= 0.5."
[p p2 r m]
(let [diff-vec (map (partial * r) (gmath/normalize (map - p2 p)))
ortho1 ((fn [[x y]] (list (- y) x)) diff-vec)
ortho2 ((fn [[x y]] (list y (- x))) diff-vec)]
(and (clear-line? (map + ortho1 p) (map + ortho1 p2) m)
(clear-line? (map + ortho2 p) (map + ortho2 p2) m))))
(defn straighten-path
"Given a path in the map m, remove unnecessary nodes of
the path. A node is removed if one can pass freely
between the previous and the next node."
([m path]
(if (> (count path) 2) (straighten-path m path nil) path))
([m [from mid to & tail] acc]
(if to
(if (clear-path? from to 0.49 m)
(recur m (list* from to tail) acc)
(recur m (list* mid to tail) (conj acc from)))
(reverse (conj acc from mid)))))
(defn to-mid-points [path]
(map (partial map (partial + 0.5)) path))
(defn to-tiles [path]
(map (partial map int) path))
(defn a*
"A* search for a grid of squares, mat. Tries to find a
path from start to goal using only walkable? tiles.
start and goal are vectors of indices into the grid,
not points in R^2."
[mat start goal factor]
(let [width (count mat)
height (count (first mat))]
(letfn [(h [{pos :pos}] (* factor (gmath/distance pos goal)))
(g [{:keys [pos parent]}]
(if parent
(+ (:g parent) (gmath/distance pos (parent :pos)))
0))
(make-node [parent pos]
(let [node {:pos pos :parent parent}
g (g node) h (h node)
f (+ g h)]
(assoc node :f f :g g :h h)))
(get-path
([node] (get-path node ()))
([{:keys [pos parent]} path]
(if parent
(recur parent (conj path pos))
(conj path pos))))
(free-tile? [tile]
(let [type (get-in mat (vec tile))]
(and type (walkable? type))))
(expand [closed pos]
(let [adj [[1 0] [0 1] [-1 0] [0 -1]]
add-pos (partial mapv + pos)]
(->> (take 4 (partition 2 1 (cycle adj)))
(map (fn [[t t2]]
(list* (map + t t2) (map add-pos [t t2]))))
(map (fn [[d t t2]]
(if (every? free-tile? [t t2]) d nil)))
(remove nil?)
(concat adj)
(map add-pos)
(remove (fn [[x y :as tile]]
(or (closed tile) (neg? x) (neg? y)
(>= x width) (>= y height)
(not (walkable? (get-in mat tile)))))))))
(add-to-open [open tile->node [{:keys [pos f] :as node} & more]]
(if node
(if (or (not (contains? open pos))
(< f (open pos)))
(recur (assoc open pos f)
(assoc tile->node pos node)
more)
(recur open tile->node more))
{:open open :tile->node tile->node}))]
(let [start-node (make-node nil start)]
(loop [closed #{}
open (pm/priority-map start (:f start-node))
tile->node {start start-node}]
(let [[curr _] (peek open) curr-node (tile->node curr)]
(when curr
(if (= curr goal)
(get-path curr-node)
(let [exp-tiles (expand closed curr)
exp-nodes (map (partial make-node curr-node) exp-tiles)
{:keys [open tile->node]}
(add-to-open (pop open) tile->node exp-nodes)]
(recur (conj closed curr) open tile->node))))))))))
(defn find-path [mat start goal]
(let [start-tile (point->tile start)
goal-tile (point->tile goal)
path (a* mat start-tile goal-tile)
point-path (to-mid-points path)
full-path (concat [start] point-path [goal])
final-path (rest (straighten-path mat full-path))]
final-path))
I recommend the Clojure High Performance Programming book for addressing questions like yours.
There are functions to unbox primitives (byte, short, int, long, float, double).
Warn-on-reflection does not apply to numeric type reflection / failure to optimize numeric code. There is a lib to force warnings for numeric reflection - primitive-math.
You can declare the types of function arguments and function return values (defn ^Integer foo [^Integer x ^Integer y] (+ x y)).
Avoid apply if you want performance.
Avoid varargs (a common reason to need apply) if you want performance. Varargs functions create garbage on every invocation (in order to construct the args map, which usually is not used outside the function body). partial always constructs a varargs function. Consider replacing the varargs (partial * x) with #(* x %), the latter can be optimized much more aggressively.
There is a tradeoff with using primitive jvm single-type arrays (they are mutible and fixed in length, which can lead to more complex and brittle code), but they will perform better than the standard clojure sequential types, and are available if all else fails to get the performance you need.
Also, use criterium to compare various implementations of your code, it has a bunch of tricks to help rule out the random things that affect execution time so you can see what really performs best in a tight loop.
Also, regarding your representation of a point as [x y] - you can reduce the space and lookup overhead of the collection holding them with (defrecord point [x y]) (as long as you know they will remain two elements only, and you don't mind changing your code to ask for (:x point) or (:y point)). You could further optimize by making or using a simple two-number java class (with the tradeoff of losing immutibility).
Im trying to implement Depth First Search in Scheme, but I can only get it to partially work.
This is my code:
(define (depth-first-search graph node neighbour path dest)
(cond ((null? neighbour) #f)
((equal? node dest) path)
((member (car neighbour) path) (depth-first-search graph node (cdr neighbour) path dest))
((memq (car neighbour) (car graph)) (depth-first-search (cdr graph) (car neighbour) (memq (car neighbour) (car graph)) (append path (list (car neighbour))) dest))
(else depth-first-search (cdr graph) path dest)))
And this is my graph, data structure:
(define complete-graph
'((a b c d e)
(b a c)
(c a b f)
(d a e h)
(e a d)
(f c g i)
(g f h i j)
(h d g j)
(i f g j)
(j g h i)))
This is how I call the procedure:
(depth-first-search complete-graph (caar complete-graph) (cdar complete-graph) (list (caar complete-graph)) 'd)
To procedure shoud return the full path frome the start-node to the dest(ination) as a list, but it only seems to work with some start and destination nodes. If I start with 'a and 'c, it returns the right list '(a b c), but if I try with 'a and 'd, I get #f in return. So it probably is something wrong with the backtracking in the algorithm. But I have looked at the code for too long, and I really can't find the problem..
Assuming node 'a has children '(b c d e), node 'b has children '(a c), node ... First you need a function that expands a node to its children.
(define (expand graph node)
(let ((c (assq node graph)))
(if c (cdr c) '())))
Second: you have to remember all visited nodes. In general hat is different from the path (maybe it does not matter in this example). Third: you need to remember all nodes you want to visit (result from the node expansion process). So define a helper function
(define (dfs* graph visited border path dest)
If there are no nodes left to visit, then no road exist.
(cond ((null? border) #f)
If the first element in border is equal to our destination, then we are happy
((eq? (car border) dest) (cons (car border) path))
Lets check all visited nodes. If the first node in border was visited before then proceed without node expansion
((memq (car border) visited)
(dfs* graph visited (cdr border) path dest))
Otherwise expand the first node of border
(else (dfs* graph
(cons (car border) visited)
(append (expand graph (car border)) (cdr border))
(cons (car border) path)
dest))))
Call that helper function with starting values for visited, border and path:
(define (dfs graph src dst)
(dfs* graph '() (list src) '() dst)
For breath first search: append the expanded node at the end of border
Edit:
a) visited and path are the same, you can drop one of them
b) the path is returned in reverse order
c) The procedure is not correct, path contains all visited nodes. But a post processing of the result of dfs* will do the job.
You don't want to change the graph as you do the depth-first search, just the current node. If you want to do things purely functionally, have your function look like:
(define (depth-first-search graph node dest path)
(let dfs ((node node) (path path))
(let ((recur (lambda (node) (dfs node (cons node path)))))
; Write code here
; Recursive calls should use recur, not dfs or depth-first-search
...)))
(returning a path or #f as the result). You can use ormap (in Racket or SRFI-1) to iterate through all neighbors of a node, returning the first value that is not #f.