-----------------------------------------------------------------------------
-- (C)2007 Joachim Schueth, Bonn
--
-- Jo's Sudoku Solver v2.1 (Ada version)
-----------------------------------------------------------------------------
-- This program solves Sodoku puzzles. The puzzle has to be presented
-- as an ASCII file. Digits can be separated by spaces. The empty fields
-- of the puzzle must be represented by the digit 0 in the input file.
-- The name of the input file is given as a command line argument.
--
-- Sample input file 'sudoku01.txt':
--
--   4 0 0  1 0 0  0 2 0
--   1 0 0  0 9 7  0 0 4
--   0 0 0  0 6 0  8 0 0
--   
--   0 0 0  0 0 9  0 0 0
--   0 0 0  2 0 0  1 7 0
--   0 0 0  0 0 0  0 5 0
--   
--   5 3 0  0 0 4  6 0 0
--   7 0 0  0 2 0  0 4 0
--   0 6 0  8 0 0  3 0 0
--
-- Sample run of the Sudoku Solver:
--
--   $ sudokusolve sudoku01.txt
--   Input:
--     4 0 0  1 0 0  0 2 0
--     1 0 0  0 9 7  0 0 4
--     0 0 0  0 6 0  8 0 0
-- 
--     0 0 0  0 0 9  0 0 0
--     0 0 0  2 0 0  1 7 0
--     0 0 0  0 0 0  0 5 0
-- 
--     5 3 0  0 0 4  6 0 0
--     7 0 0  0 2 0  0 4 0
--     0 6 0  8 0 0  3 0 0
--   Solution 1:
--     4 9 6  1 5 8  7 2 3
--     1 2 8  3 9 7  5 6 4
--     3 7 5  4 6 2  8 9 1
-- 
--     2 1 7  5 8 9  4 3 6
--     8 5 3  2 4 6  1 7 9
--     6 4 9  7 3 1  2 5 8
-- 
--     5 3 2  9 1 4  6 8 7
--     7 8 1  6 2 3  9 4 5
--     9 6 4  8 7 5  3 1 2
--   Number of solutions: 1
--
-- Have fun!
-----------------------------------------------------------------------------
with Ada.Command_Line;
with Ada.Text_IO;
use  Ada.Text_IO;
with Ada.Integer_Text_IO;
use  Ada.Integer_Text_IO;

procedure Sudokusolve is

    RootNum: constant := 3;

    SideLen: constant := RootNum * RootNum;
    FieldSz: constant := SideLen * SideLen;

    type Digit_T is range 0..SideLen;
    Empty: constant Digit_T := Digit_T'First;
    package DIO is new Ada.Text_IO.Integer_IO(Digit_T);
    use DIO;

    subtype Cell_T  is Integer range 1..FieldSz;
    type Board_T is array(Cell_T) of Digit_T;

    function Get_Board(Input: File_Type) return Board_T is
        Board: Board_T;
        C: Character;
    begin
        for I in Board'Range loop
            loop
                Get(Input, C);
                exit when C >= '0' and C <= '9';
            end loop;
            Board(I) := Character'Pos(C) - Character'Pos('0') + Empty;
        end loop;
        return Board;
    end Get_Board;

    procedure Put_Board(Board: Board_T) is
        Digit_Char: constant array(Digit_T) of Character := "0123456789";
    begin
        for I in Board'Range loop
            if (I - Board'First) mod RootNum = 0 then
                Put(' ');
            end if;    
            Put(' ' & Digit_Char(Board(I)));
            if (I - Board'First + 1) mod SideLen = 0 then
                New_Line;
                if I < Board'Last and then
                    (I - Board'First + 1) mod (RootNum * SideLen) = 0 then
                        New_Line;
                end if;
            end if;    
        end loop;
    end;

    Groups: array(1..2 * SideLen + RootNum * RootNum, 1..SideLen) of Cell_T;
    type GKind_T is (Row, Col, Box);
    Groups_of_Cell: array(Cell_T, GKind_T) of Integer range Groups'Range(1);

    procedure Make_Groups is
        GIndex: Integer;
        Cell: Cell_T;
    begin
        GIndex := Groups'First(1);
        -- Rows
        for Y in Integer range 0..SideLen - 1 loop
            for I in Groups'Range(2) loop
                Cell := Y * SideLen + (I - Groups'First(2)) + Cell_T'First;
                Groups(GIndex, I) := Cell;
                Groups_of_Cell(Cell, Row) := GIndex;
            end loop;
            GIndex := GIndex + 1;
        end loop;
        -- Columns
        for X in Integer range 0..SideLen - 1 loop
            for I in Groups'Range(2) loop
                Cell := X + (I - Groups'First(2)) * SideLen + Cell_T'First;
                Groups(GIndex, I) := Cell;
                Groups_of_Cell(Cell, Col) := GIndex;
            end loop;
            GIndex := GIndex + 1;
        end loop;
        -- Squares
        for Xbox in Integer range 0..RootNum - 1 loop
            for Ybox in Integer range 0..RootNum - 1 loop
                for X in Integer range 0..RootNum - 1 loop
                    for Y in Integer range 0..RootNum - 1 loop
                        Cell := RootNum * Xbox + RootNum * SideLen * Ybox
                                + SideLen * Y + X + Cell_T'First;
                        Groups(GIndex, RootNum * X + Y + Groups'First(2)) := Cell;
                        Groups_of_Cell(Cell, Box) := GIndex;
                    end loop;
                end loop;
                GIndex := GIndex + 1;
            end loop;
        end loop;
    end Make_Groups;

    function Allowed(Board: Board_T; Digit: Digit_T; Cell: Cell_T)
        return Boolean
    is
        GIndex: Integer;
    begin
        if Board(Cell) /= Empty and then Board(Cell) /= Digit then
            return False;
        end if;    
        for GType in Groups_of_Cell'Range(2) loop
            GIndex := Groups_of_Cell(Cell, GType);
            for I in Groups'Range(2) loop
                if Board(Groups(GIndex, I)) = Digit then
                    return False;
                end if;    
            end loop;
        end loop;
        return True;
    end Allowed;

    type DigVect is array(1..SideLen) of Digit_T;
    type Choices_T is record
        Digit: DigVect := (others => Empty);
        Len: Natural := 0;
    end record;
    type Choice_Board_T is array(Board_T'Range) of Choices_T;

    procedure Add_Choice(Choices: in out Choices_T; Digit: Digit_T) is
    begin
        Choices.Len := Choices.Len + 1;
        Choices.Digit(Choices.Len) := Digit;
    end Add_Choice;

    function Possibilities(Board: Board_T) return Choice_Board_T is
        Choice_Board: Choice_Board_T;
    begin
        for Cell in Board'Range loop
            if Board(Cell) = Empty then
                for Digit in Digit_T loop
                    if Allowed(Board, Digit, Cell) then
                        Add_Choice(Choice_Board(Cell), Digit);
                    end if;
                end loop;
            end if;
        end loop;
        return Choice_Board;
    end Possibilities;

    Solution_Number: Natural := 0;

    procedure Solve(In_Board: in Board_T) is
        Board: Board_T := In_Board;
        Choice_Board: constant Choice_Board_T := Possibilities(Board);
        Board_Modified: Boolean := False;
        Hope: Boolean := False;
        Hope_Cell: Cell_T := Cell_T'First;
        Min_Choices: Natural := Natural'Last;
        Empty_Count: Natural := 0;
        Digit: Digit_T;
    begin
        for Cell in Cell_T loop
            if Board(Cell) = Empty then
                Empty_Count := Empty_Count + 1;
                if Choice_Board(Cell).Len = 0 then
                    return;
                elsif Choice_Board(Cell).Len = 1 then
                    Digit := Choice_Board(Cell).Digit(DigVect'First);
                    if not Board_Modified or else Allowed(Board, Digit, Cell) then
                        Board(Cell) := Digit;
                        Empty_Count := Empty_Count - 1;
                        Board_Modified := True;
                    else
                        return;
                    end if;    
                elsif Choice_Board(Cell).Len < Min_Choices then
                    Min_Choices := Choice_Board(Cell).Len;
                    Hope_Cell := Cell;
                    Hope := True;
                end if;    
            end if;    
        end loop;
        if Empty_Count = 0 then
            Solution_Number := Solution_Number + 1;
            Put("Solution "); Put(Solution_Number, 0); Put(':'); New_Line;
            Put_Board(Board);
        elsif Board_Modified then
            Solve(Board);
        elsif Hope then
            for I in 1..Choice_Board(Hope_Cell).Len loop
                Board(Hope_Cell) := Choice_Board(Hope_Cell).Digit(I);
                Solve(Board);
            end loop;
        end if;
    end Solve;

    Board: Board_T;
    Input: File_Type;
begin -- Sudokusolve
    Make_Groups;
    Open(Input, In_File, Ada.Command_Line.Argument(1));
    Board := Get_Board(Input);
    Put_Line("Input:");
    Put_Board(Board);
    Solve(Board);
    Put("Number of solutions: "); Put(Solution_Number, 0); New_Line;
end Sudokusolve;