Solving sudoku by postscript.

sudoku.ps

/# {load def} bind def
/! {exch def} bind def
/M/moveto #/L/lineto #/RM/rmoveto #/RL/rlineto #
/s/stroke #/f/fill #/S/show #/CP/closepath #

/sudokuDict 256 dict def

sudokuDict begin

[
%------------ Write the problem here ---------------
    [[ ] [6] [1]  [ ] [ ] [7]  [ ] [ ] [3]]
    [[ ] [9] [2]  [ ] [ ] [3]  [ ] [ ] [ ]]
    [[ ] [ ] [ ]  [ ] [ ] [ ]  [ ] [ ] [ ]]

    [[ ] [ ] [8]  [5] [3] [ ]  [ ] [ ] [ ]]
    [[ ] [ ] [ ]  [ ] [ ] [ ]  [5] [ ] [4]]
    [[5] [ ] [ ]  [ ] [ ] [8]  [ ] [ ] [ ]]

    [[ ] [4] [ ]  [ ] [ ] [ ]  [ ] [ ] [1]]
    [[ ] [ ] [ ]  [1] [6] [ ]  [8] [ ] [ ]]
    [[6] [ ] [ ]  [ ] [ ] [ ]  [ ] [ ] [ ]]
%---------------------------------------------------
]
/board !

/len/length #/g/get #/x/exch #/clr/cleartomark #

/id { } bind def

/head { 0 get } bind def
/map { [ 3 1 roll forall ] } def
/adup { { id } map } bind def
/filter {
    [ 3 1 roll x { 2 copy x mark 3 1 roll exec { clr x } { clr pop } ifelse } forall pop ]
} def
/seq { [ 3 1 roll 1 x { } for ] } def

/arg {
    dup len
    mark
    1 index 3 add 1 roll
    1 sub dup 0 x seq
    {
        dup 3 index x
        get x
        2 index x sub
        3 add index
        def
    } forall
    clr
} def

/applyAtDict 3 dict def

/applyAt
{
    applyAtDict begin
    [/ary /i /proc] arg
    ary i get proc
    end

    % separating namespace
    exec

    applyAtDict begin
    ary x i x put
    end
} def

/includes?
{
    2 dict begin
    [/ary /val] arg
    ary { val eq } map false x { or } forall
    end
} def

/isValid
{
    1 x { len mul } forall 0 gt
} def

/isComplete
{
    dup
    1 x { len mul } forall 1 eq
    {
        dup
        0 x { head add } forall 45 eq x
        1 x { head mul } forall 362880 eq
        and
    } { pop false } ifelse
} def

/checkValid {
    true x
    { isValid and } forall
} def

/perm_delete_elem_dict 3 dict def

/perm_delete_elems
{
    perm_delete_elem_dict begin
        /i !
        /bs !
        bs i get 0 get
        /v !
        0 bs len 1 sub seq {
            dup bs x get
            x i gt
            { { v ne } filter }
            { adup }
            ifelse
        } map
    end
} def

/perm_main_dict 2 dict def

/perm_main
{
    perm_main_dict begin
    [/lst /pos] arg

    [
        lst pos get
        {
            lst adup dup
            3 -1 roll
            [ x ] pos x
            put
        } forall
    ]
    { pos perm_delete_elems } map
    { isValid } filter
    end
} def

/permutationDict 5 dict def

/permutation
{
    permutationDict begin
    [/base_lst] arg

    mark
    base_lst len 1 sub /n !
    base_lst 0
    perm_main
    0 0
    {
        [/lst /i /j] arg

        j lst len lt
        {
            % save context
            lst i j 1 add

            lst j get
            i n lt
            { i 1 add perm_main i 1 add 0 }
            {
                counttomark 1 add 1 roll
            }
            ifelse
        }
        {
            i 0 eq { exit } if
        }
        ifelse
    } loop

    clr
    
    end
} def

/deepcopy {
    { { adup } map } map
} def

/arrayEq
{
    2 dict begin
    [/a1 /a2] arg

    a1 len a2 len eq
    {
        true
        0 a1 len 1 sub seq {
            dup a1 x get x a2 x get eq
            and
        } forall
    }
    {
        false
    }
    ifelse

    end
} def

/compareStateDict 5 dict def

/compareState {
    compareStateDict begin
    [/s1 /s2] arg

    true
    0 8 seq {
        /i !
        s1 i get /r1 !
        s2 i get /r2 !
        true
        0 8 seq {
            dup r1 x get x r2 x get arrayEq
            and
            dup not { exit } if
        } forall
        and
        dup not { exit } if
    } forall

    end
} def

/blk2griddict 2 dict def

/blk2grid {
    blk2griddict begin
    /j ! /i !
    i 3 idiv 3 mul j 3 idiv add
    i 3 mod 3 mul j 3 mod add
    end
} def

/extractDict 4 dict def

/extractBlock {
    extractDict begin
    /b !
    /cand !
    0 8 seq { b x blk2grid cand 3 -1 roll get x get adup } map
    end
} def

/extractRow {
    get { adup } map
} def

/extractColumn {
    extractDict begin
    /c !
    { c get adup } map
    end
} def

/replaceDict 6 dict def

/replaceRow {
    replaceDict begin
    [/brd /r /ln] arg
    brd r get
    0 8 seq { 2 copy 3 -1 roll ln x get put } forall
    pop
    end
} def

/replaceColumn {
    replaceDict begin
    [/brd /c /ln] arg
    0 8 seq { dup brd x get x ln x get c x put } forall
    end
} def

/replaceBlock {
    replaceDict begin
    [/brd /b /ln] arg
    0 8 seq {
        /j !
        b j blk2grid x brd x get
        x ln j get put
    } forall
    end
} def

/eliminateDict 8 dict def

/eliminateLine {
    [/ln] arg
    0 8 seq {
        /i !
        ln i get
        dup len
        1 eq
        {
            0 get /v !
            0 8 seq {
                /j !
                i j ne
                {
                    ln j get
                    { v ne } filter
                    ln x j x
                    put
                } if
            } forall
        }
        {
            pop
        }
        ifelse
    } forall
} def

/eliminateRow {
    eliminateDict begin
    [/cands] arg

    0 8 seq {
        /r !
        cands r extractRow dup
        eliminateLine
        cands x r x replaceRow
    } forall

    end
} def

/eliminateColumn {
    eliminateDict begin
    [/cands] arg

    0 8 seq {
        /c !
        cands c extractColumn dup
        eliminateLine
        cands x c x replaceColumn
    } forall

    end
} def

/eliminateBlock {
    eliminateDict begin
    [/cands] arg

    0 8 seq {
        /b !
        cands b extractBlock dup
        eliminateLine
        cands x b x replaceBlock
    } forall

    end
} def

/findConcreteDict 8 dict def

/findConcrete {
    [/ln] arg

    0 8 seq { pop 0 } map /cnts !
    0 8 seq {
        ln x get { 1 sub cnts x { 1 add } applyAt } forall
    } forall

    0 8 seq {
        /i !
        cnts i get 1 eq
        {
            0 8 seq {
                /j !
                ln j get i 1 add includes?
                {
                    ln j [i 1 add] put
                } if
            } forall
        } if
    } forall
} def

/fixConcreteInRows {
    findConcreteDict begin
    [/cands] arg

    0 8 seq {
        /r !
        cands r extractRow dup
        findConcrete
        cands x r x replaceRow
    } forall

    end
} def

/fixConcreteInColumns {
    findConcreteDict begin
    [/cands] arg

    0 8 seq {
        /c !
        cands c extractColumn dup
        findConcrete
        cands x c x replaceColumn
    } forall

    end
} def

/fixConcreteInBlocks {
    findConcreteDict begin
    [/cands] arg

    0 8 seq {
        /b !
        cands b extractBlock dup
        findConcrete
        cands x b x replaceBlock
    } forall

    end
} def

/applyHeuristicsDict 4 dict def

/applyHeuristics {
    applyHeuristicsDict begin
    [/cands] arg

    /ret -1 def
    1 20 seq {
        /i !
        cands deepcopy /new_cands !

        new_cands eliminateRow
        new_cands checkValid not { exit } if
        new_cands eliminateColumn
        new_cands checkValid not { exit } if
        new_cands eliminateBlock
        new_cands checkValid not { exit } if

        new_cands fixConcreteInRows
        new_cands fixConcreteInColumns
        new_cands fixConcreteInBlocks

        new_cands checkValid not { exit } if

        cands new_cands compareState
        {
            /ret i def
            exit
        } if
        new_cands cands copy pop
    } forall

    ret
    end
} def

/checkComplete {
    1 dict begin
    [/brd] arg
    true 0 8 seq { brd x extractRow isComplete and } forall
    dup
    {
        0 8 seq { brd x extractColumn isComplete and } forall
        dup
        {
            0 8 seq { brd x extractBlock isComplete and } forall
        } if
    }
    if
    end
} def

/genInitialCandidates {
    {
        {
            dup len
            1 ge
            { adup }
            { pop 1 9 seq }
            ifelse
        } map
    } map
} def

/findPivot {
    4 dict begin
    [/cands] arg

    387420489 /min !
    0 /minRow !
    0 8 seq {
        /i !
        1 cands i get { len mul } forall
        dup
        dup
        1 gt x
        min lt and
        { /min ! i /minRow ! }
        { pop }
        ifelse
    } forall

    minRow
    end
} def

/solveSudoku_main {
    mark
    0 /cnt !
    0
    cands
    cands findPivot dup
    cands x get
    [ x permutation ] x
    0
    {
        [/d /brd /perms /p /j] arg

        j perms len lt
        {
            % push current context
            d brd perms p j 1 add
            brd deepcopy /new_brd !
            new_brd p perms j get replaceRow
            new_brd applyHeuristics 0 ge
            {
                new_brd checkComplete
                {
                    cnt 1 add /cnt !
                    new_brd
                    counttomark 1 add 1 roll
                }
                {
                    % push new context
                    d 1 add
                    new_brd
                    new_brd findPivot dup
                    new_brd x get [ x permutation ] x
                    0
                } ifelse
            } if
        }
        {
            d 0 gt not { exit } if
        } ifelse

        cnt 10 ge {
            (**There are more than 10 answers of this problem!**) =
            exit
        } if
    } loop

    clr
} def

/solveSudoku {
    16 dict begin
    [/problem] arg

    problem genInitialCandidates /cands !

    cands applyHeuristics
    0 ge
    {
        [ solveSudoku_main ]
    }
    {
        [ ]
    }
    ifelse

    end
} def

/drawBoardGrid {
    3 setlinewidth
    0    0  M 450 0 RL 0 -450 RL -450 0 RL CP s

    0 -150  M 450 0 RL s
    0 -300  M 450 0 RL s
    150  0  M 0 -450 RL s
    300  0  M 0 -450 RL s

    1 setlinewidth
    0  -50  M 450 0 RL s
    0 -100  M 450 0 RL s
    0 -200  M 450 0 RL s
    0 -250  M 450 0 RL s
    0 -350  M 450 0 RL s
    0 -400  M 450 0 RL s
    50   0  M 0 -450 RL s
    100  0  M 0 -450 RL s
    200  0  M 0 -450 RL s
    250  0  M 0 -450 RL s
    350  0  M 0 -450 RL s
    400  0  M 0 -450 RL s
} def

/drawBoard {
    16 dict begin
    [/brd /ans] arg

    gsave

    25 500 translate
    drawBoardGrid

    /Helvetica-Bold findfont 36 scalefont setfont

    0 8 seq {
        /i !
        brd i get /probRow !
        ans i get /ansRow !
        0 8 seq {
            /j !
            probRow j get dup
            len 1 eq
            {
                0 get /v !
                50 j mul 15 add -50 i mul -40 add M
                v ( ) cvs true charpath s
            }
            {
                pop
                ansRow j get
                0 get /v !
                50 j mul 15 add -50 i mul -40 add M
                v ( ) cvs true charpath f
            }
            ifelse
        } forall
    } forall

    grestore

    end
} def

/noAnswer {
    gsave
    /GothicBBB-Medium-H findfont 72 scalefont setfont
    50 700 M
    <3272244a2437212a> show
    grestore
} def


board solveSudoku /answers !

answers len 1 ge
{
    answers len 2 ge
    {
        gsave
        /GothicBBB-Medium-H findfont 28 scalefont setfont
        50 770 M
        <3272242c42743b332422246a245e24392123> show
        50 730 M
        <245f2443244424402431493d3c282437245e24392123> show
        grestore

        gsave
        50 400 translate
        0.5 0.5 scale
        board answers 0 get drawBoard
        grestore

        gsave
        305 400 translate
        0.5 0.5 scale
        board answers 1 get drawBoard
        grestore

        answers len 2 gt
        {
            gsave
            50 50 translate
            0.5 0.5 scale
            board answers 2 get drawBoard
            grestore
        } if
    }
    {
        gsave
        25 842 50 sub 500 sub translate
        board answers 0 get drawBoard
        gsave
    } ifelse
    showpage
}
{
    noAnswer
    showpage
}
ifelse

end