Source code in the pascal programming language

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.


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.