Source code in the powerbasic programming language

' The program solve fe169b4c0a73d852 in 4-5 seconds (on Intel Core i7-3770 3.40 GHz, 16 GB RAM, Windows 10 Pro).
' Test not completed with 0c9dfbae37254861 (still running after about 4 hours).
' Most of initialization is done in procedure fifteenSolver(), so it's possible to call it many times from the main function.
' No need to pass to fifteenSolver() the initial position of 0; the procedure determines it.
' Program includes procedure to create new configurations (by shuffling the correct final configuration).
' Program also includes a simple (text only) optional visualization of solving moves; the second (optional) parameter of fifteenSolver() is the pause between each move (in milliseconds).
'
' PowerBASIC compilers (both PBCC and PBWin) are 32 bits and are not that efficient when dealing with 64 bit integers (quad, only signed);
' this is not a problem for additions and subtractions, but left/right shift are quite slow;
' to speed up execution, left/right shift are done by inline X86 assembler (the PB statement is commented).

#compiler pbcc
#dim all

global Nr() as long
global Nc() as long
global n as long
global nn as long ' variable name _n not allowed
global N0() as long
global N3() as long
global N4() as long
global N2() as quad

%Ki=1
%Ke=2
%Kl=4
%Kg=8

%l=108 ' l
%r=114 ' r
%u=117 ' u
%d=100 ' d

function fY() as long
   if N2(n) = &h123456789abcdef0 then
      function=1
      exit function
   end if
   if N4(n) <= nn then
      function = fN()
      exit function
   end if
   function = 0
end function

function fZ(byval w as long) as long
   if (w and %Ki) > 0 then
      call fI()
      if fY() then
         function = 1
         exit function
      end if
      decr n
   end if
   if (w and %Kg) > 0 then
      call fG()
      if fY() then
         function = 1
         exit function
      end if
      decr n
   end if
   if (w and %Ke) > 0 then
      call fE()
      if fY() then
         function = 1
         exit function
      end if
      decr n
   end if
   if (w and %Kl) > 0 then
      call fL()
      if fY() then
         function = 1
         exit function
      end if
      decr n
   end if
   function = 0
end function

function fN() as long
   select case N0(n)
      case 0
         select case N3(n)
            case %l
               function = fZ(%Ki)
               exit function
            case %u
               function = fZ(%Ke)
               exit function
            case else
               function = fZ(%Ki + %Ke)
               exit function
         end select
      case 3
         select case N3(n)
            case %r
               function = fZ(%Ki)
               exit function
            case %u
               function = fZ(%Kl)
               exit function
            case else
               function = fZ(%Ki + %Kl)
               exit function
         end select
      case 1, 2
         select case N3(n)
            case %l
               function = fZ(%Ki + %Kl)
               exit function
            case %r
               function = fZ(%Ki + %Ke)
               exit function
            case %u
               function = fZ(%Ke + %Kl)
               exit function
            case else
               function = fZ(%Kl + %Ke + %Ki)
               exit function
         end select
      case 12
         select case N3(n)
            case %l
               function = fZ(%Kg)
               exit function
            case %d
               function = fZ(%Ke)
               exit function
            case else
               function = fZ(%Ke + %Kg)
               exit function
         end select
      case 15
         select case N3(n)
            case %r
               function = fZ(%Kg)
               exit function
            case %d
               function = fZ(%Kl)
               exit function
            case else
               function = fZ(%Kg + %Kl)
               exit function
         end select
      case 13, 14
         select case N3(n)
            case %l
               function = fZ(%Kg + %Kl)
               exit function
            case %r
               function = fZ(%Ke + %Kg)
               exit function
            case %d
               function = fZ(%Ke + %Kl)
               exit function
            case else
               function = fZ(%Kg + %Ke + %Kl)
               exit function
         end select
      case 4, 8
         select case N3(n)
            case %l
               function = fZ(%Ki + %Kg)
               exit function
            case %u
               function = fZ(%Kg + %Ke)
               exit function
            case %d
               function = fZ(%Ki + %Ke)
               exit function
            case else
               function = fZ(%Ki + %Kg + %Ke)
               exit function
         end select
      case 7, 11
         select case N3(n)
            case %d
               function = fZ(%Ki + %Kl)
               exit function
            case %u
               function = fZ(%Kg + %Kl)
               exit function
            case %r
               function = fZ(%Ki + %Kg)
               exit function
            case else
               function = fZ(%Ki + %Kg + %Kl)
               exit function
         end select
      case else
         select case N3(n)
            case %d
               function = fZ(%Ki + %Ke + %Kl)
               exit function
            case %l
               function = fZ(%Ki + %Kg + %Kl)
               exit function
            case %r
               function = fZ(%Ki + %Kg + %Ke)
               exit function
            case %u
               function = fZ(%Kg + %Ke + %Kl)
               exit function
            case else
               function = fZ(%Ki + %Kg + %Ke + %Kl)
               exit function
         end select
   end select
end function

sub fI()
   local g as long
   local a as quad
   g = (11 - N0(n)) * 4
   a = (N2(n) and lshift(15,g))
   N0(n + 1) = N0(n) + 4
   N2(n + 1) = N2(n) - a + lshift(a, 16)
   N3(n + 1) = %d
   N4(n + 1) = N4(n)
   if isfalse(Nr(rshift(a,g)) <= N0(n)\4) then
      incr N4(n + 1)
   end if
   incr n
end sub

sub fG()
   local g as long
   local a as quad
   g = (19 - N0(n)) * 4
   a = (N2(n) and lshift(15,g))
   N0(n + 1) = N0(n) - 4
   N2(n + 1) = N2(n) - a + rshift(a, 16)
   N3(n + 1) = %u
   N4(n + 1) = N4(n)
   if isfalse(Nr(rshift(a,g)) >= N0(n)\4) then
      incr N4(n + 1)
   end if
   incr n
end sub

sub fE()
   local g as long
   local a as quad
   g = (14 - N0(n)) * 4
   a = (N2(n) and lshift(15,g))
   N0(n + 1) = N0(n) + 1
   N2(n + 1) = N2(n) - a + lshift(a,4)
   N3(n + 1) = %r
   N4(n + 1) = N4(n)
   if isfalse(Nc(rshift(a,g)) <= (N0(n) mod 4)) then
      incr N4(n + 1)
   end if
   incr n
end sub

sub fL()
   local g as long
   local a as quad
   g = (16 - N0(n)) * 4
   a = (N2(n) and lshift(15,g))
   N0(n + 1) = N0(n) - 1
   N2(n + 1) = N2(n) - a + rshift(a,4)
   N3(n + 1) = %l
   N4(n + 1) = N4(n)
   if isfalse(Nc(rshift(a,g)) >= (N0(n) mod 4)) then
      incr N4(n + 1)
   end if
   incr n
end sub

function lshift(byval v as quad, byval s as dword) as quad
   'shift left v, s
   ' inline assembler shift is much faster
   !mov edx,v[4]
   !mov eax,v
   !mov ecx,s
   !shld edx,eax,cl
   !shl eax,cl
   !test ecx,32
   !jz skip
   !mov edx,eax
   !xor eax,eax
   skip:
   !mov v[4],edx
   !mov v,eax
   function = v
end function

function rshift(byval v as quad, byval s as dword) as quad
   'shift right v, s
   ' inline assembler shift is much faster
   !mov edx,v[4]
   !mov eax,v
   !mov ecx,s
   !shrd eax,edx,cl
   !shr edx,cl
   !test ecx,32
   !jz skip
   !mov eax,edx
   !xor edx,edx
   skip:
   !mov v[4],edx
   !mov v,eax
   function = v
end function

sub fifteenSolver(byval g as quad, optional byval p as long)
   local h as string
   local j as long
   local s as string
   local t as single
   t=timer
   redim Nr(0 to 15)
   redim Nc(0 to 15)
   redim N0(0 to 99)
   redim N3(0 to 100)
   redim N4(0 to 99)
   redim N2(0 to 99)
   array assign Nr()=3, 0, 0, 0, 0, 1, 1, 1, 1, 2, 2, 2, 2, 3, 3, 3
   array assign Nc()=3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2, 3, 0, 1, 2
   n = 0
   nn = 0
   h = hex$(g, 16)
   cls
   print "Puzzle: ";lcase$(h)
   call ShowConfiguration(h, 2)
   print
   print
   N0(0) = instr(h, "0") - 1
   N2(0) = g
   call solve()
   print using$("Solution found in #### moves: ", n);
   for j = 1 to n
      s = s + chr$(N3(j))
   next
   print s
   print "Time = ";format$(timer-t, "#####.########");" seconds"
   if p then
      call showMoves(h, s, n, p)
   end if
end sub

sub solve()
   if fN() then
      exit sub
   else
      n = 0
      incr nn
      call solve()
   end if
end sub

function createPuzzle(byval j as long) as quad
   local q as quad
   local h as string
   local z as long
   local d as long
   local r as long
   local u as long
   randomize timer
   q=&h123456789abcdef0
   h = hex$(q, 16)
   u = 0
   while j > 0 ' number of moves to do
      do
         d = rnd(1, 4) ' -1 +1 -4 +4
      loop while d = u
      u = -d
      r = rnd(1, 3) ' repetitions
      while r
         z = instr(h, "0")
         select case d
            case 1 ' -1
               if (z mod 4) <> 1 then
                  mid$(h, z, 1) = mid$(h, z - 1, 1)
                  mid$(h, z - 1, 1) = "0"
                  decr j
               end if
            case 2 ' +1
               if (z mod 4) <> 0 then
                  mid$(h, z , 1) = mid$(h, z + 1, 1)
                  mid$(h, z + 1, 1) = "0"
                  decr j
               end if
            case 3 ' -4
               if z >= 5 then
                  mid$(h, z, 1) = mid$(h, z - 4, 1)
                  mid$(h, z - 4, 1) = "0"
                  decr j
               end if
            case 4 ' +4
               if z <= 12 then
                  mid$(h, z , 1) = mid$(h, z + 4, 1)
                  mid$(h, z + 4, 1) = "0"
                  decr j
               end if
         end select
         decr r
      wend
   wend
   function = val("&h"+h)
end function

sub shoWMoves(byval h as string, byval s as string, byval m as long, byval p as long)
   local j as long
   local z as long
   local d as long
   cursor off
   call ShowConfiguration(h, 12)
   for j = 1 to m
      d = asc(mid$(s, j, 1))
      z = instr(h, "0")
      select case d
         case %l
            if (z mod 4) <> 1 then
               mid$(h, z, 1) = mid$(h, z - 1, 1)
               mid$(h, z - 1, 1) = "0"
            end if
         case %r
            if (z mod 4) <> 0 then
               mid$(h, z , 1) = mid$(h, z + 1, 1)
               mid$(h, z + 1, 1) = "0"
            end if
         case %u
            if z >= 5 then
               mid$(h, z, 1) = mid$(h, z - 4, 1)
               mid$(h, z - 4, 1) = "0"
            end if
         case %d
            if z <= 12 then
               mid$(h, z , 1) = mid$(h, z + 4, 1)
               mid$(h, z + 4, 1) = "0"
            end if
      end select
      call ShowConfiguration(h, 12)
      sleep p
   next
   locate 20,1
   print "Press any key ..."
   cursor on
   waitkey$
   cls
end sub

sub ShowConfiguration(byval h as string, i as long)
   local r as long
   local c as long
   local x as string
   for r = 1 to 4
      for c = 1 to 4
         locate r + i, c + c - 1
         x = mid$(h, r * 4 - 4 + c, 1)
         if x = "0" then
            x = " "
         end if
         print x;
      next
   next
end sub

function PBMain() as long
   call fifteenSolver(&hfe169b4c0a73d852, 1000)
  'call fifteenSolver(createPuzzle(100), 1000)
  'call fifteenSolver(&h0c9dfbae37254861, 1000)
end function