Lưu ý: Các code mẫu dưới đây chỉ mang tính tham khảo và có thể không AC được bài tập này

Code mẫu của flashmt

const fi='';
      dx:array[1..4] of longint=(-1,0,1,0);
      dy:array[1..4] of longint=(0,1,0,-1);
      e:array[1..6,1..6] of longint=((0,3,5,2,4,0),(4,0,1,6,0,3),
      (2,6,0,0,1,5),(5,1,0,0,6,2),(3,0,6,1,0,4),(0,4,2,5,3,0));
      maxn=51;
      maxdinh=maxn*maxn*24;
      maxcanh=maxdinh*4;
var m,n,sd,sx,sy,fx,fy,s,nh,low,high:longint;
    val:array[1..maxn,1..maxn] of longint;
    a,c:array[1..maxcanh*2] of longint;
    pos,cur,d,h,p:array[0..maxdinh] of longint;
    free:array[1..maxdinh] of boolean;
    b:array[1..maxn,1..maxn,1..6,1..6] of longint;

procedure rf;
var i,j:longint;
begin
     read(m,n);
     for i:=1 to m do
         for j:=1 to n do
             read(val[i,j]);
     read(sx,sy,fx,fy);
     high:=((fx-1)*n+fy)*24;
     low:=high-23;
end;

procedure initvec;
var i,j,p,q:longint;
begin
     sd:=0;
     for i:=1 to m do
       for j:=1 to n do
         for p:=1 to 6 do
           for q:=1 to 6 do
             if (p<>q) and (p<>7-q) then
             begin
                  inc(sd);
                  b[i,j,p,q]:=sd;
                  if (i=sx) and (j=sy) and (p=1) and (q=2) then s:=sd;
             end;
end;

procedure calc(p,q,k:longint;var pp,qq:longint);
begin
     if odd(k) then
     begin
          if k=1 then
          begin
               qq:=p; pp:=7-q;
          end
          else
          begin
               pp:=q; qq:=7-p;
          end;
     end
     else
     begin
          pp:=p;
          if k=2 then qq:=7-e[p,q]
          else qq:=e[p,q];
     end;
end;

procedure initedge;
var i,j,p,q,k,ii,jj,x,y,pp,qq:longint;
begin
     for i:=1 to m do
       for j:=1 to n do
         for p:=1 to 6 do
           for q:=1 to 6 do
             if (p<>q) and (p<>7-q) then
             begin
                  x:=b[i,j,p,q];
                  cur[x]:=cur[x-1]; pos[x]:=cur[x]+1;
                  for k:=1 to 4 do
                  begin
                       ii:=i+dx[k]; jj:=j+dy[k];
                       if (ii<1) or (jj<1) or (ii>m) or (jj>n) then continue;
                       inc(cur[x]);
                       calc(p,q,k,pp,qq);
                       y:=b[ii,jj,pp,qq];
                       a[cur[x]]:=y;
                       c[cur[x]]:=val[ii,jj]*(7-qq);
                  end;
             end;
     pos[sd+1]:=cur[sd]+1;
end;

procedure update(x:longint);
var cha,con:longint;
begin
     con:=p[x];
     if con=0 then
     begin
          inc(nh); con:=nh;
     end;
     cha:=con shr 1;
     while (cha>0) and (d[h[cha]]>d[x]) do
     begin
          h[con]:=h[cha];
          p[h[con]]:=con;
          con:=cha;
          cha:=con shr 1;
     end;
     h[con]:=x; p[x]:=con;
end;

function pop:longint;
var cha,con,x:longint;
begin
     pop:=h[1];
     x:=h[nh]; dec(nh);
     cha:=1; con:=2;
     while con<=nh do
     begin
          if (con<nh) and (d[h[con+1]]<d[h[con]]) then inc(con);
          if d[x]<=d[h[con]] then break;
          h[cha]:=h[con];
          p[h[cha]]:=cha;
          cha:=con;
          con:=cha shl 1;
     end;
     h[cha]:=x; p[x]:=cha;
end;

procedure pr;
var i,x,y:longint;
begin
     for i:=1 to sd do
     begin
          d[i]:=1000000000;
          free[i]:=true;
     end;
     d[s]:=5*val[sx,sy];
     update(s);
     repeat
           x:=pop; free[x]:=false;
           if (x>=low) and (x<=high) then
           begin
                writeln(d[x]); exit;
           end;
           for i:=pos[x] to pos[x+1]-1 do
           begin
                y:=a[i];
                if free[y] and (d[y]>d[x]+c[i]) then
                begin
                     d[y]:=d[x]+c[i];
                     update(y);
                end;
           end;
     until nh=0;
end;

begin
     assign(input,fi); reset(input);
     rf;
     initvec;
     initedge;
     pr;
     close(input);
end.

Code mẫu của ladpro98

program xucxac;
uses    math;
type    e=record
        x,y,f,u,r:longint;
        end;
const   maxn=55;
        maxT=6*6*6*maxn*maxn;
        fi='';
var     h:array[1..maxT] of e;
        pos:array[1..maxn,1..maxn,1..6,1..6,1..6] of longint;
        d:array[1..maxn,1..maxn,1..6,1..6,1..6] of longint;
        a:array[1..maxn,1..maxn] of longint;
        res,m,n,sx,sy,fx,fy,nh:longint;

procedure input;
var     inp:text;
        i,j:longint;
begin
        assign(inp,fi);
        reset(inp);
        readln(inp,m,n);
        for i:=1 to m do
        begin
                for j:=1 to n do read(inp,a[i,j]);
                readln(inp);
        end;
        readln(inp,sx,sy,fx,fy);
        close(inp);

end;

procedure update(x,y,f,u,r:longint);
var     c,p:longint;

begin
        c:=pos[x,y,f,u,r];
        if c=0 then
        begin
                inc(nh);
                c:=nh;
        end;
        repeat
                p:=c div 2;
                if (p=0) or (d[h[p].x,h[p].y,h[p].f,h[p].u,h[p].r]<=d[x,y,f,u,r]) then break;
                h[c]:=h[p];
                pos[h[c].x,h[c].y,h[c].f,h[c].u,h[c].r]:=c;
                c:=p;
        until false;
        h[c].x:=x;h[c].y:=y;h[c].f:=f;h[c].u:=u;h[c].r:=r;
        pos[x,y,f,u,r]:=c;
end;

function extract:e;
var     v,temp:e;
        c,p:longint;
begin
        temp:=h[1];
        v:=h[nh];
        dec(nh);p:=1;
        repeat
                c:=2*p;
                if (c<nh) and (d[h[c+1].x,h[c+1].y,h[c+1].f,h[c+1].u,h[c+1].r]<
                d[h[c].x,h[c].y,h[c].f,h[c].u,h[c].r]) then inc(c);
                if (c>nh) or (d[v.x,v.y,v.f,v.u,v.r]<=
                d[h[c].x,h[c].y,h[c].f,h[c].u,h[c].r]) then break;
                h[p]:=h[c];
                pos[h[p].x,h[p].y,h[p].f,h[p].u,h[p].r]:=p;
                p:=c;
        until false;
        h[p]:=v;
        pos[v.x,v.y,v.f,v.u,v.r]:=p;
        exit(temp);
end;

function getAdj(i:longint;u:e):e;
var     t:e;
begin
        if i=1 then
        begin
                t.x:=u.x-1;
                t.y:=u.y;
                t.f:=7-u.u;
                t.u:=u.f;
                t.r:=u.r;
        end
        else
        if i=2 then
        begin
                t.x:=u.x;
                t.y:=u.y+1;
                t.f:=u.f;
                t.u:=7-u.r;
                t.r:=u.u;
        end
        else
        if i=3 then
        begin
                t.x:=u.x+1;
                t.y:=u.y;
                t.f:=u.u;
                t.u:=7-u.f;
                t.r:=u.r;
        end
        else
        begin
                t.x:=u.x;
                t.y:=u.y-1;
                t.f:=u.f;
                t.u:=u.r;
                t.r:=7-u.u;
        end;
        exit(t);
end;

function inBound(i,j:longint):boolean;
begin
        exit((1<=i) and (i<=m) and (1<=j) and (j<=n));
end;

procedure init;
var     i,j,p,q,r:longint;
begin
        nh:=0;
        for i:=1 to m do
        for j:=1 to n do
        for p:=1 to 6 do
        for q:=1 to 6 do
        for r:=1 to 6 do
        d[i,j,p,q,r]:=high(longint);
        d[sx,sy,1,2,3]:=0;
        res:=high(longint);
end;

procedure dijkstra;
var     u,v:e;
        t:longint;
begin
        update(sx,sy,1,2,3);
        repeat
                u:=extract;
                if (u.x=fx) and (u.y=fy) then
                res:=min(res,d[u.x,u.y,u.f,u.u,u.r]);
                for t:=1 to 4 do
                begin
                        v:=getAdj(t,u);
                        if inBound(v.x,v.y) then
                        if d[v.x,v.y,v.f,v.u,v.r]>d[u.x,u.y,u.f,u.u,u.r]+a[v.x,v.y]*(7-v.u) then
                        begin
                                d[v.x,v.y,v.f,v.u,v.r]:=d[u.x,u.y,u.f,u.u,u.r]+a[v.x,v.y]*(7-v.u);
                                update(v.x,v.y,v.f,v.u,v.r);
                        end;
                end;
        until nh=0;
end;

begin
        input;
        init;
        dijkstra;
        write(res+5*a[sx,sy]);
end.

Code mẫu của RR

{$R+,Q+}
PROGRAM XUCXAC;
CONST
  finp='';
  fout='';
  maxn=50;
  oo=1000000000;
TYPE
  rec=record i,j,f,u,r:longint; end;
VAR
  fin:array[1..maxn,1..maxn,1..6,1..6,1..6] of byte;
  hpos,d:array[1..maxn,1..maxn,1..6,1..6,1..6] of longint;
  a:array[1..maxn,1..maxn] of longint;
  h:array[1..maxn*maxn*6*6*6] of rec;
  kq,m,n:longint;
  hsize:longint;
  si,sj,fi,fj:longint;
Procedure ReadInput;
Var
  f:text;
  i,j:longint;
Begin
  Assign(f,finp); Reset(f);
  Readln(f,m,n);
  For i:=1 to m do
    For j:=1 to n do
      Read(f,a[i,j]);
  Readln(f,si,sj,fi,fj);
  Close(f);
End;
Procedure Init;
Var
  i,j,f,u,r:longint;
Begin
  For i:=1 to maxn do
  For j:=1 to maxn do
  For f:=1 to 6 do
  For u:=1 to 6 do
  For r:=1 to 6 do
    d[i,j,f,u,r]:=oo;
  hsize:=1;
  with h[1] do
    begin
      i:=si; j:=sj;
      f:=1; u:=2; r:=3;
    end;
  hpos[si,sj,1,2,3]:=1;
  d[si,sj,1,2,3]:=5*a[si,sj];
End;
Procedure WriteOutput;
Var
  fo:text;
Begin
  Assign(fo,fout); Rewrite(fo);
  Writeln(fo,kq);
  Close(fo);
End;
Procedure Swap(var a,b:longint);
Var
  temp:longint;
Begin
  temp:=a; a:=b; b:=temp;
End;
Procedure SwapRec(var a,b:rec);
Var
  temp:rec;
Begin
  temp:=a; a:=b; b:=temp;
End;
Procedure DownHeap(i:longint);
Var
  j:longint;
Begin
  j:=i shl 1;
  while (j<=hsize) do
    begin
      if (j<hsize) and
         (d[h[j+1].i,h[j+1].j,h[j+1].f,h[j+1].u,h[j+1].r]
         <d[h[j].i,h[j].j,h[j].f,h[j].u,h[j].r])
      then inc(j);
      if  d[h[j].i,h[j].j,h[j].f,h[j].u,h[j].r]
         <d[h[i].i,h[i].j,h[i].f,h[i].u,h[i].r] then
        begin
          Swap(hpos[h[i].i,h[i].j,h[i].f,h[i].u,h[i].r],
               hpos[h[j].i,h[j].j,h[j].f,h[j].u,h[j].r]);
          Swaprec(h[i],h[j]);
        end;
      i:=j; j:=i shl 1;
    end;
End;
Procedure Extract;
Begin
  Swap(hpos[h[1].i,h[1].j,h[1].f,h[1].u,h[1].r],
       hpos[h[hsize].i,h[hsize].j,h[hsize].f,h[hsize].u,h[hsize].r]);
  Swaprec(h[1],h[hsize]);
  dec(hsize);
  DownHeap(1);
End;
Procedure Insert(i,j,f,u,r:longint);
Var
  k:longint;
Begin
  inc(hsize); k:=hsize;
  while (k>1) and
  (d[h[k shr 1].i,h[k shr 1].j,h[k shr 1].f,h[k shr 1].u,h[k shr 1].r]>d[i,j,f,u,r]) do
     begin
       h[k]:=h[k shr 1];
       hpos[h[k].i,h[k].j,h[k].f,h[k].u,h[k].r]:=k;
       k:=k shr 1;
     end;
  h[k].i:=i; h[k].j:=j; h[k].f:=f; h[k].u:=u; h[k].r:=r;
  hpos[i,j,f,u,r]:=k;
End;
Procedure Heapify(i:longint);
Begin
  while (i>1) and
  (d[h[i shr 1].i,h[i shr 1].j,h[i shr 1].f,h[i shr 1].u,h[i shr 1].r]
  >d[h[i].i,h[i].j,h[i].f,h[i].u,h[i].r]) do
    begin
      Swap(hpos[h[i].i,h[i].j,h[i].f,h[i].u,h[i].r],
           hpos[h[i shr 1].i,h[i shr 1].j,h[i shr 1].f,h[i shr 1].u,h[i shr 1].r]);
      SwapRec(h[i],h[i shr 1]);
      i:=i shr 1;
    end;
End;
Procedure Dijkstra;
Var
  i,j,f,u,r:longint;
Begin
  while hsize>0 do
  begin
    i:=h[1].i; j:=h[1].j;
    f:=h[1].f; u:=h[1].u; r:=h[1].r;
    If (i=fi) and (j=fj) then
      begin
        kq:=d[i,j,f,u,r];
        exit;
      end;
    fin[i,j,f,u,r]:=1;
    Extract;
    if  (j<n) and (fin[i,j+1,f,7-r,u]=0)
    and (d[i,j+1,f,7-r,u]>d[i,j,f,u,r]+r*a[i,j+1]) then
      begin
        d[i,j+1,f,7-r,u]:=d[i,j,f,u,r]+r*a[i,j+1];
        if hpos[i,j+1,f,7-r,u]=0 then
          Insert(i,j+1,f,7-r,u)
        else heapify(hpos[i,j+1,f,7-r,u]);
      end;
    if  (j>1) and (fin[i,j-1,f,r,7-u]=0)
    and (d[i,j-1,f,r,7-u]>d[i,j,f,u,r]+(7-r)*a[i,j-1]) then
      begin
        d[i,j-1,f,r,7-u]:=d[i,j,f,u,r]+(7-r)*a[i,j-1];
        if hpos[i,j-1,f,r,7-u]=0 then
          Insert(i,j-1,f,r,7-u)
        else heapify(hpos[i,j-1,f,r,7-u]);
      end;
    if  (i<m) and (fin[i+1,j,u,7-f,r]=0)
    and (d[i+1,j,u,7-f,r]>d[i,j,f,u,r]+f*a[i+1,j]) then
      begin
        d[i+1,j,u,7-f,r]:=d[i,j,f,u,r]+f*a[i+1,j];
        if hpos[i+1,j,u,7-f,r]=0 then
          Insert(i+1,j,u,7-f,r)
        else heapify(hpos[i+1,j,u,7-f,r]);
      end;
    if  (i>1) and (fin[i-1,j,7-u,f,r]=0)
    and (d[i-1,j,7-u,f,r]>d[i,j,f,u,r]+(7-f)*a[i-1,j]) then
      begin
        d[i-1,j,7-u,f,r]:=d[i,j,f,u,r]+(7-f)*a[i-1,j];
        if hpos[i-1,j,7-u,f,r]=0 then
          Insert(i-1,j,7-u,f,r)
        else heapify(hpos[i-1,j,7-u,f,r]);
      end;
  end;
End;
BEGIN
  ReadInput;
  Init;
  Dijkstra;
  WriteOutput;
END.

Code mẫu của ll931110

{$MODE DELPHI}
Program XUCXAC;
Const
  input  = '';
  output = '';
  maxn = 50;
  maxp = 654;
  minp = 123;
  maxc = 1000000000;
Type
  rec = record
    x,y,z: integer;
  end;
Var
  m,n,sx,sy,fx,fy: integer;
  free: array[0..maxn + 1, 0..maxn + 1, minp..maxp] of boolean;
  d,pos: array[1..maxn, 1..maxn, minp..maxp] of integer;
  a: array[1..maxn,1..maxn] of integer;
  heap: array[1..1500000] of rec;
  u,v,p: integer;
  p1,p2,p3: integer;
  uk,vk,pk,sk: integer;
  nHeap: integer;

Procedure LoadGraph;
Var
  f: text;
  i,j: integer;
Begin
  Assign(f, input);
    Reset(f);

  Readln(f, m, n);
  For i:= 1 to m do
    For j:= 1 to n do read(f, a[i,j]);

  Readln(f, sx, sy, fx, fy);
  Close(f);
End;

Procedure init;
Var
  i,j,k: integer;
Begin
  For i:= 1 to m do
    For j:= 1 to n do
      For k:= minp to maxp do d[i,j,k]:= maxc;
  d[sx,sy,minp]:= 5 * a[sx,sy];

  Fillchar(pos, sizeof(pos), 0);
  Fillchar(free, sizeof(free), false);
  For i:= 1 to m do
    For j:= 1 to n do
      For k:= minp to maxp do free[i,j,k]:= true;

  nHeap:= 0;
End;

Procedure update(ux,vx,px: integer);
Var
  child,parent: integer;
Begin
  child:= pos[ux,vx,px];
  If child = 0 then
    Begin
      inc(nHeap);
      child:= nHeap;
    End;

  parent:= child div 2;
  While (parent > 0)
    and (d[heap[parent].x,heap[parent].y,heap[parent].z] > d[ux,vx,px]) do
      Begin
        heap[child]:= heap[parent];
        pos[heap[child].x,heap[child].y,heap[child].z]:= child;

        child:= parent;
        parent:= child div 2;
      End;

  with heap[child] do
    Begin
      x:= ux;
      y:= vx;
      z:= px;
    End;
  pos[ux,vx,px]:= child;
End;

Procedure pop;
Var
  r,c,vx,vy,vz: integer;
Begin
  with heap[1] do
    Begin
      u:= x;
      v:= y;
      p:= z;
    End;

  with heap[nHeap] do
    Begin
      vx:= x;
      vy:= y;
      vz:= z;
    End;
  dec(nHeap);

  r:= 1;
  While r * 2 <= nHeap do
    Begin
      c:= r * 2;
      If (c < nHeap) and
        (d[heap[c + 1].x,heap[c + 1].y,heap[c + 1].z] < d[heap[c].x,heap[c].y,heap[c].z]) then inc(c);

      If d[vx,vy,vz] <= d[heap[c].x,heap[c].y,heap[c].z] then break;
      heap[r]:= heap[c];
      pos[heap[r].x,heap[r].y,heap[r].z]:= r;
      r:= c;
    End;

  with heap[r] do
    Begin
      x:= vx;
      y:= vy;
      z:= vz;
    End;
  pos[vx,vy,vz]:= r;
End;

Procedure adjust;
Var
  tmp: integer;
Begin
  If free[uk,vk,pk] then
    Begin
      tmp:= d[u,v,p] + a[uk,vk] * sk;
      If d[uk,vk,pk] > tmp then
        Begin
          d[uk,vk,pk]:= tmp;
          update(uk,vk,pk);
        End;
    End;
End;

Procedure rollup;
Begin
  uk:= u - 1;
  vk:= v;

  sk:= 7 - p1;
  pk:= (7 - p2) * 100 + p1 * 10 + p3;

  adjust;
End;

Procedure rolldown;
Begin
  uk:= u + 1;
  vk:= v;

  sk:= p1;
  pk:= p2 * 100 + (7 - p1) * 10 + p3;

  adjust;
End;

Procedure rollleft;
Begin
  uk:= u;
  vk:= v - 1;

  sk:= 7 - p3;
  pk:= p1 * 100 + p3 * 10 + (7 - p2);

  adjust;
End;

Procedure rollright;
Begin
  uk:= u;
  vk:= v + 1;

  sk:= p3;
  pk:= p1 * 100 + (7 - p3) * 10 + p2;

  adjust;
End;

Procedure Dijkstra;
Begin
  update(sx,sy,minp);
  Repeat
    pop;
    If (u = fx) and (v = fy) then exit;
    free[u,v,p]:= false;

    p1:= p div 100;
    p2:= (p mod 100) div 10;
    p3:= p mod 10;

    rollup;
    rolldown;
    rollleft;
    rollright;
  Until nHeap = 0;
End;

Procedure printresult;
Var
  f: text;
  val,i: integer;
Begin
  Assign(f, output);
    Rewrite(f);

  val:= maxc;
  For i:= minp to maxp do
    if val > d[fx,fy,i] then val:= d[fx,fy,i];

    Writeln(f, val);
  Close(f);
End;

Begin
  LoadGraph;
  init;
  Dijkstra;
  printresult;
End.