'******************************************************************************
'Subject: Compute shortest paths from a single source.
'Author : Sjoerd.J.Schaper
'Date : 11-21-2005
'Code : all QBasic's, FreeBasic extendable
'Keys : [Esc] quit program
' press any key to read the next pattern
'******************************************************************************
'This program is copyright (c) 2005 by the author. It is made available as is,
'and no warranty - about the program, its performance, or its conformity to any
'specification - is given or implied. It may be used, modified, and distributed
'freely, as long as the original author is credited as part of the final work.
'******************************************************************************
REM $STATIC
DEFINT A-Z
DECLARE FUNCTION ingrid ()
'input an ASCII grid
'
Link to a sample input file in lif-format.
DECLARE SUB inita ()
'initialize arrays
DECLARE SUB mark (r, s, g$)
'read markers A, B, digit, Spc or bar
DECLARE SUB paynt (k, sw)
'graphics routine
DECLARE SUB edges (aw(), r, s, v)
'erase edges (v < 0) or set weights
DECLARE SUB search ()
'execute Dijkstra's algorithm
DECLARE SUB relax (k)
'optimize paths relative to node k
DECLARE SUB spath ()
'draw the shortest path A -> B
DECLARE SUB downheap (u, tx)
'make a heap from a semi-heap
DECLARE SUB upheap (u)
'bubble up a decreased value
DECLARE SUB swop (u, v)
'swap vertices, store indices
CONST INF = 32766
CONST MODE = 12, dW = 640, dH = 480
' set screenmode, width, height
CONST MAX = 78
' maximum grid size 78 for QBasic 1.0,
' 101 using the QB /Ah switch
'CONST MAX = dH \ 2 - 1 ' FreeBasic only
DIM SHARED m, n, mn, src, trg
'height, width, number of nodes, source, target
mn = MAX * MAX - 1
DIM SHARED d(mn), i(mn), j(mn)
' distance label, priority queue, node index
DIM SHARED p(mn), a(mn, 3), w(mn, 3)
' parent node, adjacency list, weights
OPEN ".\dijkstra.lif" FOR INPUT AS #1
DO
CLS
IF NOT ingrid THEN EXIT DO ' read grid
search ' find
spath ' shortest path
SLEEP
LOOP UNTIL INKEY$ = CHR$(27) ' [Esc] quit program
CLOSE
SYSTEM
SUB downheap (u, tx)
v = u
t = 2 * u + 1 ' left child
DO UNTIL t > tx ' (v is a leaf then)
IF t < tx THEN ' compare both children
IF d(i(t + 1)) < d(i(t)) THEN
t = t + 1 ' right child
END IF
END IF
IF d(i(t)) < d(i(v)) THEN
swop t, v
v = t ' smallest child
t = 2 * v + 1 ' next descendant
ELSE
EXIT DO ' v has the heap property
END IF
LOOP
END SUB
SUB edges (aw(), r, s, v)
k = r * n + s
IF r > 0 THEN
aw(k, 0) = v: aw(k - n, 2) = v ' N & S
END IF
IF s > 0 THEN
aw(k, 1) = v: aw(k - 1, 3) = v ' W & E
END IF
IF r < m - 1 THEN
aw(k, 2) = v: aw(k + n, 0) = v ' S & N
END IF
IF s < n - 1 THEN
aw(k, 3) = v: aw(k + 1, 1) = v ' E & W
END IF
END SUB
FUNCTION ingrid
ingrid = 0: n = 0
DO
IF EOF(1) THEN
ingrid = n > 0: EXIT DO
END IF
LINE INPUT #1, g$: g$ = RTRIM$(g$)
'
SELECT CASE LEFT$(g$, 2)
CASE "#C", "#D", "#L" ' comments
IF n THEN
ingrid = -1: EXIT DO ' go!
END IF
CASE "#N", "#P", "#R" ' grid width and height
g$ = LTRIM$(MID$(g$, 3))
t = INSTR(g$, " ")
n = VAL(LEFT$(g$, t)) ' n columns
m = VAL(MID$(g$, t + 1)) ' m rows
IF m < 2 OR m > MAX THEN m = MAX
IF n < m THEN n = m ' square grid
r = 0: inita
CASE ELSE ' read pattern
FOR s = 0 TO LEN(g$) - 1
mark r, s, MID$(g$, s + 1, 1)
NEXT s: r = r + 1
END SELECT
LOOP
END FUNCTION
SUB inita
mn = m * n - 1
src = 0: trg = mn
paynt k, 0
FOR k = 0 TO mn
i(k) = k: j(k) = k ' queue, indices
d(k) = INF: p(k) = -1 ' keys, predecessor
'
FOR t = 0 TO 3
a(k, t) = -1 ' clear links
w(k, t) = 1 ' set unit distances
NEXT t
r = k \ n
s = k - r * n
IF r > 0 THEN
a(k, 0) = k - n: a(k - n, 2) = k ' N & S
END IF ' adjacency list for an
IF s > 0 THEN ' undirected grid graph
a(k, 1) = k - 1: a(k - 1, 3) = k ' W & E
END IF
NEXT k
END SUB
SUB mark (r, s, g$)
IF g$ = "" OR g$ = " " THEN EXIT SUB
t = ASC(UCASE$(g$)) - 48
k = r * n + s
SELECT CASE t
CASE 0 TO 9
edges w(), r, s, t ' set weights
paynt k, t + 3 ' gray blocks
CASE 17
src = k ' source "A"
CASE 18
trg = k ' target "B"
CASE ELSE
edges a(), r, s, -1 ' reset edges
paynt k, 13 ' black blox
END SELECT
END SUB
SUB paynt (k, sw)
STATIC fl
IF NOT fl THEN
DIM c(15) AS LONG
c(0) = &H303030: c(7) = &H242424
c(1) = &H10002A: c(8) = &H202020
c(2) = &H200A00: c(9) = &H1C1C1C
c(3) = &H343434: c(10) = &H181818
c(4) = &H303030: c(11) = &H151515
c(5) = &H2C2C2C: c(12) = &H121212
c(6) = &H282828: c(13) = &H0
SCREEN MODE: PALETTE USING c(0)
VIEW (8, 15)-(dW - 9, dH - 9)
COLOR 13: fl = -1
END IF
r = k \ n
s = k - r * n
SELECT CASE sw
CASE 0
WINDOW SCREEN (-1, -1)-(n, m)
LINE (-1, -1)-(n, m), 0, BF
CASE 1
u = k = src
v = k = trg
IF NOT v THEN LINE -(s, r), 1 ' draw path
IF u OR v THEN
t = 1 - u
CIRCLE (s, r), .25, t ' extremities
PAINT (s, r), t, t
END IF
CASE ELSE ' terrain, walls
LINE (s - .5, r - .5)-(s + .5, r + .5), sw, BF
END SELECT
END SUB
SUB relax (k)
u = i(k)
FOR s = 0 TO 3
v = a(u, s) ' adjacency list item
IF v > -1 THEN ' edge present
IF j(v) < k THEN ' successor node in open set
IF d(v) > d(u) + w(u, s) THEN
d(v) = d(u) + w(u, s) ' improve current estimate
p(v) = u ' make u the parent of v
upheap j(v) ' restore heap order
END IF
END IF
END IF
NEXT s
END SUB
SUB search
d(i(src)) = 0
IF src > 0 THEN swop src, 0 ' move the source to the tree root
FOR k = mn TO 0 STEP -1 ' start at rightmost leave
IF i(0) = trg THEN EXIT FOR ' target settled
swop 0, k ' move the root to the closed set
downheap 0, k - 1 ' restore heap order
relax k ' update paths relative to previous root
NEXT k
END SUB
SUB spath
k = trg
IF p(k) = -1 THEN EXIT SUB ' zero path
DO ' backtrack
paynt k, 1 ' write path
k = p(k)
LOOP UNTIL k = -1
g$ = "length " + STR$(d(trg))
IF d(trg) = INF THEN g$ = "infinite"
LOCATE 1, 2: PRINT g$ ' shortest path
END SUB
SUB swop (u, v)
SWAP i(u), i(v)
j(i(u)) = u: j(i(v)) = v
END SUB
SUB upheap (u)
v = u
DO UNTIL v = 0 ' (root is an orphan)
t = (v - 1) \ 2 ' parent
IF d(i(t)) > d(i(v)) THEN
swop t, v ' must be smaller than child
v = t ' next ascendant
ELSE
EXIT DO ' v has the heap property
END IF
LOOP
END SUB