Data commit

Task/Dijkstras-algorithm/Pascal/dijkstras-algorithm-1.pas

@@ -0,0 +1,162 @@
+program dijkstra(output);
+
+type
+  { We dynamically build the list of vertices from the edge list,
+    just to avoid repeating ourselves in the graph input. Vertices are linked
+    together via their `next` pointers to form a list of all vertices (sorted by
+    name), while the `previous` pointer indicates the previous vertex along the
+    shortest path to this one. }
+  vertex = record
+    name: char;
+    visited: boolean;
+    distance: integer;
+    previous: ^vertex;
+    next: ^vertex;
+  end;
+
+  vptr = ^vertex;
+
+  { The graph is specified as an array of these }
+  edge_desc = record
+    source: char;
+    dest: char;
+    weight: integer;
+  end;
+
+const
+  { the input graph }
+  edges:    array of edge_desc = (
+    (source:'a'; dest:'b'; weight:7),
+    (source:'a'; dest:'c'; weight:9),
+    (source:'a'; dest:'f'; weight:14),
+    (source:'b'; dest:'c'; weight:10),
+    (source:'b'; dest:'d'; weight:15),
+    (source:'c'; dest:'d'; weight:11),
+    (source:'c'; dest:'f'; weight:2),
+    (source:'d'; dest:'e'; weight:6),
+    (source:'e'; dest:'f'; weight:9)
+  );
+
+  { find the shortest path to all nodes starting from this one }
+  origin: char = 'a';
+
+var
+  head_vertex: vptr = nil;
+  curr, next, closest: vptr;
+  vtx: vptr;
+  dist: integer;
+  edge: edge_desc;
+  done: boolean = false;
+
+{ allocate a new vertex node with the given name and `next` pointer }
+function new_vertex(key: char; next: vptr): vptr;
+
+  var
+    vtx: vptr;
+  begin
+    new(vtx);
+    vtx^.name := key;
+    vtx^.visited := false;
+    vtx^.distance := maxint;
+    vtx^.previous := nil;
+    vtx^.next := next;
+    new_vertex := vtx;
+  end;
+
+
+{ look up a vertex by name; create it if needed }
+function find_or_make_vertex(key: char): vptr; var
+    vtx, prev, found: vptr;
+    done: boolean;
+
+  begin
+
+    found := nil;
+    if head_vertex = nil then
+      head_vertex := new_vertex(key, nil)
+    else if head_vertex^.name > key then
+      head_vertex := new_vertex(key, head_vertex);
+
+    if head_vertex^.name = key then
+      found := head_vertex
+    else begin
+      prev := head_vertex;
+      vtx := head_vertex^.next;
+      done := false;
+      while not done do
+        if vtx = nil then
+          done := true
+        else if vtx^.name >= key then
+          done := true
+        else begin
+          prev := vtx;
+          vtx := vtx^.next
+        end;
+      if vtx <> nil then
+        if vtx^.name = key then
+          found := vtx;
+      if found = nil then begin
+        prev^.next := new_vertex(key, vtx);
+        found := prev^.next;
+      end
+    end;
+    find_or_make_vertex := found
+  end;
+
+{ display the path to a vertex indicated by its `previous` pointer chain }
+procedure write_path(vtx: vptr);
+  begin
+    if vtx <> nil then begin
+      if vtx^.previous <> nil then begin
+        write_path(vtx^.previous);
+        write('→');
+      end;
+      write(vtx^.name);
+    end;
+  end;
+
+begin
+  curr := find_or_make_vertex(origin);
+  curr^.distance := 0;
+  curr^.previous := nil;
+  while not done do begin
+    for edge in edges do begin
+      if edge.source = curr^.name then begin
+        next := find_or_make_vertex(edge.dest);
+        dist := curr^.distance + edge.weight;
+        if dist < next^.distance then begin
+           next^.distance := dist;
+           next^.previous := curr;
+        end
+      end
+    end;
+    curr^.visited := true;
+    closest := nil;
+    vtx := head_vertex;
+    while vtx <> nil do begin
+      if not vtx^.visited then
+        if closest = nil then
+          closest := vtx
+        else if vtx^.distance < closest^.distance then
+          closest := vtx;
+      vtx := vtx^.next;
+    end;
+    if closest = nil then
+      done := true
+    else if closest^.distance = maxint then
+      done := true;
+    curr := closest;
+  end;
+  writeln('Shortest path to each vertex from ', origin, ':');
+  vtx := head_vertex;
+  while vtx <> nil do begin
+    write(vtx^.name, ':', vtx^.distance);
+    if vtx^.distance > 0 then begin
+      write(' (');
+      write_path(vtx);
+      write(')');
+    end;
+    writeln();
+    vtx := vtx^.next;
+  end
+end.

Task/Dijkstras-algorithm/Pascal/dijkstras-algorithm-2.pas

@@ -0,0 +1,107 @@
+program Dijkstra_console;
+// Demo of Dijkstra's algorithm.
+// Free Pascal (Lazarus), console application.
+
+uses SysUtils;
+type
+  TNodeSet = (setA, setB, setC);
+  TNode = record
+    NodeSet : TNodeSet;
+    PrevIndex : integer;  // previous node in path leading to this node
+    PathLength : integer; // total length of path to this node
+  end;
+
+const
+// Rosetta code task
+  NR_NODES = 6;
+  START_INDEX = 0;
+  NODE_NAMES: array [0..NR_NODES - 1] of string = ('a','b','c','d','e','f');
+  // LENGTHS[j,k] = length of branch j -> k, or -1 if no such branch exists.
+  LENGTHS : array [0..NR_NODES - 1] of array [0..NR_NODES - 1] of integer
+  = ((-1, 7, 9,-1,-1,14),
+     (-1,-1,10,15,-1,-1),
+     (-1,-1,-1,11,-1, 2),
+     (-1,-1,-1,-1, 6,-1),
+     (-1,-1,-1,-1,-1, 9),
+     (-1,-1,-1,-1,-1,-1));
+
+var
+  nodes : array [0..NR_NODES - 1] of TNode;
+  j, j_min, k : integer;
+  lastToSetA, nrInSetA: integer;
+  branchLength, trialLength, minLength : integer;
+  lineOut : string;
+begin
+  // Initialize nodes: all in set C
+  for j := 0 to NR_NODES - 1 do begin
+    nodes[j].NodeSet := setC;
+    // No need to initialize PrevIndex and PathLength, as they are
+    //   not used until a value has been assigned by the algorithm.
+  end;
+
+  // Begin by transferring the start node to set A
+  nodes[START_INDEX].NodeSet := setA;
+  nodes[START_INDEX].PathLength := 0;
+  nrInSetA := 1;
+  lastToSetA := START_INDEX;
+
+  // Transfer nodes to set A one at a time, until all have been transferred
+  while (nrInSetA < NR_NODES) do begin
+
+    // Step 1: Work through branches leading from the node that was most recently
+    //         transferred to set A, and deal with end nodes in set B or set C.
+    for j := 0 to NR_NODES - 1 do begin
+      branchLength := LENGTHS[ lastToSetA, j];
+      if (branchLength >= 0) then begin
+        // If the end node is in set B, and the path to the end node via lastToSetA
+        //   is shorter than the existing path, then update the path.
+        if (nodes[j].NodeSet = setB) then begin
+          trialLength := nodes[lastToSetA].PathLength + branchLength;
+          if (trialLength < nodes[j].PathLength) then begin
+            nodes[j].PrevIndex := lastToSetA;
+            nodes[j].PathLength := trialLength;
+          end;
+        end
+        // If the end node is in set C, transfer it to set B.
+        else if (nodes[j].NodeSet = setC) then begin
+          nodes[j].NodeSet := setB;
+          nodes[j].PrevIndex := lastToSetA;
+          nodes[j].PathLength := nodes[lastToSetA].PathLength + branchLength;
+        end;
+      end;
+    end;
+
+    // Step 2: Find the node in set B with the smallest path length,
+    //         and transfer that node to set A.
+    //         (Note that set B cannot be empty at this point.)
+    minLength := -1; // just to stop compiler warning "might not have been initialized"
+    j_min := -1; // index of node with smallest path length; will become >= 0
+    for j := 0 to NR_NODES - 1 do begin
+      if (nodes[j].NodeSet = setB) then begin
+        if (j_min < 0) or (nodes[j].PathLength < minLength) then begin
+          j_min := j;
+          minLength := nodes[j].PathLength;
+        end;
+      end;
+    end;
+    nodes[j_min].NodeSet := setA;
+    inc( nrInSetA);
+    lastToSetA := j_min;
+  end;
+
+  // Write result to console
+  WriteLn( SysUtils.Format( 'Shortest paths from node %s:', [NODE_NAMES[START_INDEX]]));
+  for j := 0 to NR_NODES - 1 do begin
+    if (j <> START_INDEX) then begin
+      k := j;
+      lineOut := NODE_NAMES[k];
+      repeat
+        k := nodes[k].PrevIndex;
+        lineOut := NODE_NAMES[k] + ' -> ' + lineOut;
+      until (k = START_INDEX);
+      lineOut := SysUtils.Format( '%3s: length %3d,  ',
+                 [NODE_NAMES[j], nodes[j].PathLength]) + lineOut;
+      WriteLn( lineOut);
+    end;
+  end;
+end.