!Stick2It.F90
Program Stick2It
!2006.03.10.1625cst JMS -A700:GeForce3/NT4.0:Sp6/APF9.0/f90gl1.2.1:glut3.7
!Solution aid for 9x9 puzzles.
!This program is not warranted for any particular purpose.
!Use this program at your own risk.
!Compiled using: Absoft Pro Fortran 9.0
!------------------
 implicit none
  integer*4::nSteps,nStepSto(81)
  integer*1::i,i1,i2,iu,j,j1,j2,ju,k,k1,M,N,Nu
  integer*1::L(9,9,0:9)
  integer*1::Nin(9,9),Nout(9,9)
  character::cType*22
  integer*4::nUnResolved(0:81)
  integer*4::nTry2(81),nT,Lsto(9,9,0:9,81)
!------------------
! data((Nin(i,j),j=1,9),i=1,9) /  &
!            6,0,3,0,0,0,2,0,4    &
!           ,0,0,0,9,0,2,0,0,0    &
!           ,0,1,0,0,0,0,0,6,0    &
!           ,0,0,1,6,8,9,7,0,0    &
!           ,0,0,0,0,0,0,0,0,0    &
!           ,0,0,6,2,4,7,5,0,0    &
!           ,0,9,0,0,0,0,0,5,0    &
!           ,0,0,0,5,0,8,0,0,0    &
!           ,5,0,4,0,0,0,6,0,1  /
!     Puzzle #240 in: "Su Doku for Dummies"
!            rated: "Diabolical"

   write(6,"(' Stick2It.exe vsn. 0.7 - Jeff Setterholm  2006.03.10')")
   write(6,"(' This program is not warranted for any particular purpose.')")
   write(6,"('              Use this program at your own risk.')")
   write(6,"('  Input data: Stick2It.dat 9 rows of 9 integers [1,9]')")

   open(unit=14,file='Stick2It.dat',action='read')
     do i=1,9 ;read(14,*) (Nin(i,j),j=1,9) ;end do
   close(14)

   do i=1,9 ;write(6,"(1x,9i3)") Nin(i,1:9) ;enddo
  
   open(unit=15,file='Stick2It.out',action='write')
   write(15,"('Stick2It.exe vsn. 0.7 - Jeff Setterholm  2006.03.10')")
   write(15,"('This program is not warranted for any particular purpose.')")
   write(15,"('             Use this program at your own risk.')")
   write(15,"(' Input data: Stick2It.dat 9 rows of 9 integers [1,9]')")
   write(15,*)
   do i=1,9 ;write(15,"(9i3)") Nin(i,1:9) ;enddo
   write(15,*)
   write(15,"(' Solution sequence: Stick2It.out')")

   nTry2=0 ;nT=0 ;Lsto=0
   nSteps=0
   Nout=Nin
                L       =0
   do i=1,9 ;do j=1,9 ;N=Nin(i,j)
     if(N.eq.0) then 
       Do k=1,9 ;L(i,j,k)=k ;enddo 
     endif
     if(N.gt.0) then
       L(i,j,N)=0  !=N
       L(i,j,0)=N
     endif
   enddo ;enddo
   do i=1,9 ;do j=1,9 ;N=Nin(i,j)
     if(N.ne.0) then
       do i1=1,9 ;if(i1.ne.i) L(i1,j,N)=0 ;enddo
       do j1=1,9 ;if(j1.ne.j) L(i,j1,N)=0 ;enddo
       i2=i-mod(i-1,3) ;j2=j-mod(j-1,3)
       do i1=i2,i2+2 ;do j1=j2,j2+2
         if((i1.ne.i).or.(j1.ne.j)) L(i1,j1,N)=0
       enddo ;enddo
     endif
   enddo ;enddo
   cType='Initial Puzzle Values '
   goto 15

10 continue
      L(iu,ju,1:9) =  0
      L(iu,ju,  0) = Nu
      L(iu,ju, Nu) =  0  != Nu
   Nout(iu,ju    ) = Nu
   do i1=1,9 ;if(i1.ne.iu) L(i1,ju,Nu)=0 ;enddo
   do j1=1,9 ;if(j1.ne.ju) L(iu,j1,Nu)=0 ;enddo
   i2=iu-mod(iu-1,3) ;j2=ju-mod(ju-1,3)
   do i1=i2,i2+2 ;do j1=j2,j2+2
     if((i1.ne.iu).or.(j1.ne.ju)) L(i1,j1,Nu)=0
   enddo ;enddo
15 nUnResolved(nT)=0
   do i=1,9 ;do j=1,9 ;M=L(i,j,0)
     if(M.le.0) nUnResolved(nT)=nUnResolved(nT)+1
   enddo ;enddo
   do i=1,9 ;do j=1,9 ;M=L(i,j,0)    !Tidy up
     if(M.le.0) then; M=0
       do k=1,9 ;
         if(L(i,j,k).gt.0) then
           M=M-1
         endif
       enddo
       L(i,j,0)=M 
       if(M.eq. 0) then   !Invalid result
         cType='Intended operation    '
         write( 6,"( 1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
                     iu,ju,Nu,nSteps,cType
         write(15,"(/1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
                     iu,ju,Nu,nSteps,cType
         cType='Resulting error       '
         iu=i ;ju=j; Nu=0 
         write( 6,"( 1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
                     iu,ju,Nu,nSteps,cType
         write(15,"(/1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
                     iu,ju,Nu,nSteps,cType
         if(nT.eq.0) goto 45
         goto 35
       endif     
     endif
   enddo ;enddo
   nSteps=nSteps+1
   call ShowL(iu,ju,L,Nin,Nu,nSteps,cType)
   if(nUnResolved(nT).eq.0) then
     goto 45
   endif

20 continue
   iu=0 ;ju=0 ;Nu=0
   cType='Single Choice         '
   do i=1,9 ;do j=1,9 ;M=L(i,j,0)
     if(M.le.0) then; M=0
       do k=1,9 ;
         if(L(i,j,k).gt.0) then
           M=M-1 ;iu=i ;ju=j ;Nu=k
         endif
       enddo
       L(i,j,0)=M
       if(M.eq.-1) goto 10
     endif
   enddo ;enddo

   cType='Single Choice - Row   '
   do i=1,9 ;do k=1,9 ;M=0
     do j=1,9 
       if((L(i,j,0).lt.0).and.(L(i,j,k).gt.0)) then
         M=M-1 ;iu=i ;ju=j ;Nu=k
       endif
     end do
     if(M.eq.-1) goto 10
   enddo ;enddo

   cType='Single Choice - Column'
   do j=1,9 ;do k=1,9 ;M=0
     do i=1,9 
       if((L(i,j,0).lt.0).and.(L(i,j,k).gt.0)) then
         M=M-1 ;iu=i ;ju=j ;Nu=k
       endif
     end do
     if(M.eq.-1) goto 10
   enddo ;enddo

   cType='Single Choice -  Group'
   do i=1,9,3 ;do j=1,9,3
     do k=1,9 ;M=0
       do i1=i,i+2 ;do j1=j,j+2 ;
         if((L(i1,j1,0).lt.0).and.(L(i1,j1,k).gt.0)) then
           M=M-1 ;iu=i1 ;ju=j1 ;Nu=k
         endif
       end do ;end do
       if(M.eq.-1) goto 10
     end do
   enddo ;enddo

   nT=nT+1
30 cType='DualChoice-Trial&Error'
   if(nTry2(nT).eq.0) then
     Lsto(1:9,1:9,0:9,nT)=L
     nStepSto(nT)=nSteps
   endif
35 nTry2(nT)=nTry2(nT)+1 ;k=0
   L=Lsto(1:9,1:9,0:9,nT)
   nSteps=nStepSto(nT)
   do i=1,9 ;do j=1,9 ;M=L(i,j,0)
     if(M.eq.-2) then  
!       (M.lt.0)          ...could be used & would catch > dual-choice.
       do k1=1,9
         if(L(i,j,k1).gt.0)then
           k=k+1
           if(k.eq.nTry2(nT)) then
             iu=i ;ju=j ;Nu=k1
             write(cType,"(i2,':T&E: i=',i1,' j=',i1,' N=',i1)") nT,i,j,k1
             goto 10      ! ^ this is the nesting of the trial & error test.
           endif
          endif
        enddo
      endif
    enddo ;end do
    nTry2(nT)=0
    Lsto(1:9,1:9,0:9,nT)=0
    nT=nT-1
    if(nT.le.0) then
!     cType='Trial&Error-insuffic. '
      nSteps=nStepSto(nT)
      goto 45
    endif
    L=Lsto(1:9,1:9,0:9,nT)
    nSteps=nStepSto(nT)
    goto 30
     
45 iu=0 ;ju=0; Nu=0  
   cType='All values resolved   '
   if(nUnResolved(nT).gt.0)  &
   write(cType,"('UnResolved: ',i3,7x)") nUnResolved(nT)

50 call ShowL(iU,jU,L,Nin,Nu,nSteps,cType)
   write(15,*)
   do i=1,9 ;write(15,"(9i3)") L(i,1:9,0) ;enddo
   close(15)     
   write(6,"('  Solution sequence: Stick2It.out')")
   do i=1,9 ;write(6,"(1x,9i3)") L(i,1:9,0) ;enddo
   write(6,*)     
   pause 'Press "enter" to exit.'
End Program Stick2It
!---------------------------------------------------------------------------7 9
Subroutine ShowL(iu,ju,L,Nin,Nu,nSteps,cType)
!2006.03.07.0945cst JMS -A700:GeForce3/NT4.0:Sp6/APF9.0/f90gl1.2.1:glut3.7
!Printout for the solution to the 9x9 puzzle
!------------------
 implicit none
  integer*1::i,iu,j,ju,k,Nu
  integer*4::nSteps
  character::cType*22
  integer*1::Nin(9,9)
  integer*1::L(9,9,0:9)
!------------------
   write( 6,"( 1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
               iu,ju,Nu,nSteps,cType
   write(15,"(/1x,'i=',i1,' j=',i1,' N=',i1,' nStep=',i2,2x,a22)")  &
               iu,ju,Nu,nSteps,cType
   do i=1,9
   write(15,"('|',3(i2,1x,9i1.0,'/',i2,1x,9i1.0,'/',i2,1x,9i1.0,'|'))") &
                   ((L(i,j,k),k=0,9),j=1,9)
   if((i.eq.3).or.(i.eq.6)) &
   write(15,"(118('-'))")
   end do       
  return
End Subroutine ShowL
!---------------------------------------------------------------------------7 9

