;;; algorithms.el --- implementations of algorithms for CS381
;; Copyright (C) 2005 Michael Olson
;; This file is not part of GNU Emacs.
;; This 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, or (at your option) any later
;; version.
;;
;; This 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;; Commentary:
;; This is a listing of the algorithms that are implemented by this
;; file. Helper functions are not listed here. All algorithms have a
;; consistency check with sample data.
;; All Pairs (using Floyd-Warshall algorithm)
;; function: all-pairs
;; status: finished
;; Transitive Closure
;; function: transitive-closure
;; status: finished
;; Shortest path weights (using Dijkstra's Algorithm)
;; function: dijkstra
;; status: finished
;; Depth-First Search
;; function: dfs
;; status: finished
;; Stronly-Connected Components (using Kosaraju's Algorithm)
;; function: strongly-connected-components
;; status: not completely finished -- returns PREV from last DFS
;; rather than connected components
;;; Code:
;;; Helper functions
(defun make-2dlist (rows cols fun)
"Return a 2-dimensional list with ROWS 'rows' and COLS 'columns'.
FUN is a function that is called with current row and column.
The return value from FUN is used to intiailize the new
2-dimensional list."
(let ((i 0)
2dlist)
(while (< i rows)
(let ((j 0)
row)
(while (< j cols)
(setq row (cons (funcall fun i j) row))
(setq j (1+ j)))
(setq 2dlist (cons (nreverse row) 2dlist)))
(setq i (1+ i)))
(nreverse 2dlist)))
(defun make-2dlist-from-2dlist (m fun)
"Make a 2-dimensional list from M, another 2-dimensional list.
FUN is a function that is called with current row, column, and
value of M at that row and column."
(make-2dlist (length m)
(length (car m))
`(lambda (row col)
(funcall ,fun row col
(nth col (nth row m))))))
(defun make-inf-weight-2dlist (weight-matrix)
"Return a copy of WEIGHT-MATRIX, replacing any 0 entries with 'inf.
If current row and column are equal, use 0."
(make-2dlist-from-2dlist
weight-matrix
#'(lambda (row col val)
(if (eq row col)
0
(if (and val
(not (eq val 0)))
val
'inf)))))
(defun extract-min (q list)
"Return the position of minimum element that is in both LIST and Q.
Anything in LIST that is not a number will not be considered."
(let (min min-val)
(dolist (el q)
(let ((val (nth el list)))
(when (and (numberp val)
(or (not min)
(< val min-val)))
(setq min el
min-val val))))
(or min
(car q))))
(defun adjacencies (n weight-matrix)
"Return a list of vertices in WEIGHT-MATRIX that are adjacent to N."
(let ((i 0)
(row (nth n weight-matrix))
adj)
(while (< i (length row))
(when (numberp (nth i row))
(setq adj (cons i adj)))
(setq i (1+ i)))
adj))
(defun transpose-adjacencies (adjacencies &optional sort-fn)
"Transpose the adjacency list in ADJACENCIES.
If SORT-FN is specified, use it to sort the list."
(let ((new-adj (make-list (1+ (length adjacencies)) nil))
(i 0))
(dolist (row adjacencies)
(setq i (1+ i))
(dolist (el row)
(let ((el-cdr (nthcdr el new-adj)))
(setcar el-cdr (cons i (car el-cdr))))))
(if sort-fn
(mapcar #'(lambda (row)
(sort row sort-fn))
(cdr new-adj))
(cdr new-adj))))
(defun extract-forest (prev)
"Return the connected components from the given PREV list."
;; NOTE: This doesn't work perfectly yet.
(let* ((len (length prev))
(processed (make-list len nil))
(i 1)
(adj-list-cur 0)
adj-list)
(while (<= i len)
(let ((cur i)
proc
result)
(while cur
(cond ((setq proc (nth cur processed))
;; add to previous proc'th adj-list
;; but only if proc != adj-list-cur
(when (not (equal proc adj-list-cur))
(let ((row (nthcdr proc adj-list)))
(setcar row (nconc (car row) result))
(setq result nil)))
(setq cur nil))
(t
(setcar (nthcdr cur processed) adj-list-cur)
(setq result (cons cur result)
cur (nth cur prev)))))
(when result
(setq adj-list (append adj-list (list result))
adj-list-cur (1+ adj-list-cur))))
(setq i (1+ i)))
adj-list))
;;; All-Pairs algorithm
(defun all-pairs (graph)
"Return the all-pairs representation of GRAPH.
This is based on the Floyd-Warshall algorithm.
A list will be returned. The car is the distances. The car of
the cdr is the predecessors.
It is assumed that GRAPH is sqaure."
(let ((m (make-inf-weight-2dlist graph))
(pred (make-2dlist-from-2dlist
graph
#'(lambda (row col val)
(if (> val 0)
row
'inf))))
(len (length graph))
(k 0))
(while (< k len)
(let ((i 0))
(while (< i len)
(let ((j 0))
(while (< j len)
(let* ((ik (nth k (nth i m)))
(kj (nth j (nth k m)))
(ij-elem (nthcdr j (nth i m)))
(sum (and (not (eq ik 'inf))
(not (eq kj 'inf))
(+ ik kj))))
(when (and sum
(or (eq (car ij-elem) 'inf)
(> (car ij-elem) sum)))
(setcar ij-elem sum)
(setcar (nthcdr j (nth i pred))
(nth j (nth k pred)))))
(setq j (1+ j))))
(setq i (1+ i))))
(setq k (1+ k)))
(list m pred)))
;; Sample data
(unless (equal
(all-pairs '((0 0 5 0 3)
(2 0 0 1 4)
(2 6 0 0 2)
(0 1 0 0 0)
(0 0 3 4 0)))
'(((0 8 5 7 3)
(2 0 7 1 4)
(2 6 0 6 2)
(3 1 8 0 5)
(5 5 3 4 0))
((inf 3 0 4 0)
(1 inf 0 1 1)
(2 2 inf 4 2)
(1 3 0 inf 1)
(2 3 4 4 inf))))
(message "all-pairs: Consistency error"))
;;; Transitive Closure algorithm
(defun transitive-closure (graph)
"Return the transitive closure of GRAPH.
It is assumed that GRAPH is sqaure."
(let ((m (make-2dlist-from-2dlist
graph
#'(lambda (row col val)
(if (> val 0)
t
nil))))
(len (length graph))
(k 0))
(while (< k len)
(let ((i 0))
(while (< i len)
(let ((j 0))
(while (< j len)
(let ((ik (nth k (nth i m)))
(kj (nth j (nth k m))))
(when (and ik kj)
(setcar (nthcdr j (nth i m))
t)))
(setq j (1+ j))))
(setq i (1+ i))))
(setq k (1+ k)))
m))
;; Sample data
(unless (equal
(transitive-closure
'((0 0 0 0 1)
(1 0 0 0 0)
(0 1 0 0 0)
(0 0 0 1 0)
(0 0 0 0 1)))
'((nil nil nil nil t)
(t nil nil nil t)
(t t nil nil t)
(nil nil nil t nil)
(nil nil nil nil t)))
(message "transitive-closure: Consistency error"))
;;; Dijkstra's Algorithm
(defun dijkstra (source weight-matrix)
"Return the shortest path weights from SOURCE to other vertices of
given WEIGHT-MATRIX. The result is a list."
(let* ((len (length weight-matrix))
(dist (make-list len 'inf))
s q u)
;; dist[source] = 0
(setcar (nthcdr source dist) 0)
;; build q
(let ((i 0))
(while (< i len)
(setq q (cons i q)
i (1+ i))))
;; loop through q
(while q
(setq u (extract-min q dist)
q (delq u q)
s (cons u s)) ; `s' is ornamental
(dolist (v (adjacencies u weight-matrix))
(when (numberp (nth u dist)) ; dist[u] != 'inf
(let ((sum (+ (nth u dist)
(nth v (nth u weight-matrix)))))
(when (or (not (numberp (nth v dist)))
(> (nth v dist)
sum))
(setcar (nthcdr v dist) sum))))))
dist))
;; Sample data
(unless (and (equal
(dijkstra
0
'((inf 10 3 inf inf)
(inf inf 1 2 inf)
(inf 4 inf 8 2)
(inf inf inf inf 7)
(inf inf inf 9 inf)))
'(0 7 3 9 5))
(equal
(dijkstra
1
'((inf 10 3 inf inf)
(inf inf 1 2 inf)
(inf 4 inf 8 2)
(inf inf inf inf 7)
(inf inf inf 9 inf)))
'(inf 0 1 2 3)))
(message "dijkstra: Consistency error"))
;;; Depth-First Search
(defvar dfs-time 0)
(defun dfs-visit (u color prev dist finish adjacencies)
(setq dfs-time (1+ dfs-time))
(setcar (nthcdr u color) 'gray)
(setcar (nthcdr u dist) dfs-time)
(dolist (v (nth u adjacencies))
(when (eq (nth v color) 'white)
(setcar (nthcdr v prev) u)
(dfs-visit v color prev dist finish adjacencies)))
(setcar (nthcdr u color) 'black)
(setq dfs-time (1+ dfs-time))
(setcar (nthcdr u finish) dfs-time))
(defun dfs (adjacencies &optional vertex-order)
(let* ((len (1+ (length adjacencies)))
(color (make-list len 'white))
(prev (make-list len nil))
(dist (make-list len 'inf))
(finish (make-list len 'inf)))
;; we have to move everything up one due to fscking index-at-1
(setq adjacencies (cons nil adjacencies))
(setq dfs-time 0)
;; initialize vertex-order
(unless vertex-order
(let ((i 1))
(while (<= i len)
(setq vertex-order (cons i vertex-order))
(setq i (1+ i))))
(setq vertex-order (nreverse vertex-order)))
;; visit vertices
(dolist (u vertex-order)
(when (eq (nth u color) 'white)
(dfs-visit u color prev dist finish adjacencies)))
(list (cdr dist) (cdr finish) (cdr prev))))
;; Sample data
(unless (equal
(dfs '((2)
(3 4)
(5 7)
(1 5)
(3)
(3 7)
(9)
(7)
(8)))
'((1 2 3 13 4 17 6 8 7)
(16 15 12 14 5 18 11 9 10)
(nil 1 2 2 3 nil 3 9 7)))
(message "dfs: Consistency error"))
(unless (equal
(transpose-adjacencies
'((2)
(3 4)
(5 7)
(1 5)
(3)
(3 7)
(9)
(7)
(8))
'<)
'((4)
(1)
(2 5 6)
(2)
(3 4)
nil
(3 6 8)
(9)
(7)))
(message "transpose-adjacencies: Consistency error"))
;;; Strongly-Connected Components
(defun strongly-connected-components (adjacencies)
"Find the strongly-connected components of the graph given in
ADJACENCIES, which is in the form of an adjacency list."
;; NOTE: This returns PREV (from the last DFS) rather than the
;; connected components, since I haven't perfected the
;; extract-forest routine yet.
(let* ((len (length adjacencies))
(dfs-result (dfs adjacencies))
(finish-result (cons nil (nth 1 dfs-result)))
finish-order)
;; sort and transpose the adjacenct vertexes by decreasing finish
;; result
(setq adjacencies (transpose-adjacencies
adjacencies
#'(lambda (s1 s2)
(> (nth s1 finish-result)
(nth s2 finish-result)))))
;; compute finish order
(let ((i 1))
(while (<= i len)
(setq finish-order (cons i finish-order))
(setq i (1+ i))))
(setq finish-order
(sort finish-order
#'(lambda (s1 s2)
(> (nth s1 finish-result)
(nth s2 finish-result)))))
;; call DFS
(setq dfs-result (dfs adjacencies finish-order))
;; extract forest
;; (extract-forest (nth 2 dfs-result))
(nth 2 dfs-result)))
;; Sample data
(unless (equal
(strongly-connected-components
'((2)
(3 4)
(5 7)
(1 5)
(3)
(3 7)
(9)
(7)
(8)))
'(nil 4 nil 1 3 nil nil 7 8))
(message "strongly-connected-components: Consistency error"))
(provide 'algorithms)
;; algorithms.el ends here