Data update

Task/Dijkstras-algorithm/Forth/dijkstras-algorithm.fth

@@ -0,0 +1,158 @@
+\ utility routine to increment a variable
+: 1+! 1 swap +! ;
+
+\ edge data
+variable edge-count
+0 edge-count !
+create edges
+  'a , 'b ,  7 , edge-count 1+!
+  'a , 'c ,  9 , edge-count 1+!
+  'a , 'f , 14 , edge-count 1+!
+  'b , 'c , 10 , edge-count 1+!
+  'b , 'd , 15 , edge-count 1+!
+  'c , 'd , 11 , edge-count 1+!
+  'c , 'f ,  2 , edge-count 1+!
+  'd , 'e ,  6 , edge-count 1+!
+  'e , 'f ,  9 , edge-count 1+!
+
+\ with accessors
+: edge 3 * cells edges + ;
+: edge-from   edge ;
+: edge-to     edge 1 cells + ;
+: edge-weight edge 2 cells + ;
+
+\ vertex data and acccessor
+create vertex-names edge-count @ 2 * cells allot
+: vertex-name cells vertex-names + ;
+
+variable vertex-count
+0 vertex-count !
+
+\ routine to look up a vertex by name
+: find-vertex
+    -1 swap
+    vertex-count @ 0 ?do
+        dup i vertex-name @ = if swap drop i swap leave then
+    loop
+    drop
+;
+
+\ routine to add a new vertex name if not found
+: add-vertex
+    dup find-vertex dup -1 = if
+        swap vertex-count @ vertex-name !
+        vertex-count dup @ swap 1+!
+        swap drop
+    else
+        swap
+        drop
+    then
+;
+
+\ routine to add vertices to name table and replace names with indices in edges
+: get-vertices
+    edge-count @ 0 ?do
+        i edge-from @ add-vertex i edge-from !
+        i edge-to   @ add-vertex i edge-to   !
+    loop
+;
+
+\ call it
+get-vertices
+
+\ variables to hold state during algorithm run
+create been-visited
+vertex-count @ cells allot
+: visited cells been-visited + ;
+
+create prior-vertices
+vertex-count @ cells allot
+: prior-vertex cells prior-vertices + ;
+
+create distances
+vertex-count @ cells allot
+: distance cells distances + ;
+
+variable origin
+variable current-vertex
+variable neighbor
+variable current-distance
+variable tentative
+variable closest-vertex
+variable minimum-distance
+variable vertex
+
+\ call with origin vertex name on stack
+: dijkstra ( origin -- )
+
+    find-vertex origin !
+
+    been-visited vertex-count @ cells 0 fill
+    prior-vertices vertex-count @ cells -1 fill
+    distances vertex-count @ cells -1 fill
+
+    0 origin @ distance !  \ distance to origin is 0
+
+    origin @ current-vertex ! \ current vertex is the origin
+
+    begin
+
+    edge-count @ 0 ?do
+        i edge-from @ current-vertex @ = if \ if edge is from current
+            i edge-to @ neighbor !          \ neighbor vertex
+            neighbor @ distance @ current-distance !
+            current-vertex @ distance @ i edge-weight @ + tentative !
+            current-distance @ -1 = tentative @ current-distance @ < or if
+                tentative @ neighbor @ distance !
+                current-vertex @ neighbor @ prior-vertex !
+            then
+        else
+        then
+    loop
+
+    1 current-vertex @ visited ! \ current vertex has now been visited
+    -1 closest-vertex !
+
+    vertex-count @ 0 ?do
+        i visited @ 0= if
+            -1 minimum-distance !
+            closest-vertex @ dup -1 <> if
+                distance @ minimum-distance !
+            else
+                drop
+            then
+            i distance @ -1 <>
+                minimum-distance @ -1 = i distance @ minimum-distance @ < or
+              and if
+                i closest-vertex !
+            then
+        then
+    loop
+
+    closest-vertex @ current-vertex !
+    current-vertex @ -1 = until
+
+    cr
+    ." Shortest path to each vertex from " origin @ vertex-name @ emit ': emit cr
+    vertex-count @ 0 ?do
+        i origin @ <> if
+            i vertex-name @ emit ." : " i distance @ dup
+            -1 = if
+                drop
+                ." ∞ (unreachable)"
+            else
+                .
+                '( emit
+                i vertex !
+                begin
+                    vertex @ vertex-name @ emit
+                    vertex @ origin @ <> while
+                        ." ←"
+                        vertex @ prior-vertex @ vertex !
+                repeat
+                ') emit
+            then
+            cr
+        then
+    loop
+;