Keskustelu: Koodit: 8th: Sudokun ratkaisija graafisella käyttöliittymällä

\
\ loader.8th
\
needs file/getc


ns?

ns: loader

[ 10, 13, 46, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57 ] constant chars

: init-vars
  1 "column" t:!
  1 "line" t:!
  0 "cell" t:!
  a:new "data" t:! ;

: column+=1
  "column" t:@ n:1+
  "column" t:!  ;

: cell+=1
  "cell" t:@ n:1+
  "cell" t:! ;

: data@
  "data" t:@ ;

: cr
  column+=1 ;

: newline
  "line" t:@ n:1+
  "line" t:!
  1 "column" t:! ;

: zero
  data@ 0 a:push drop
  column+=1
  cell+=1 ;

: one
  data@ 1 a:push drop
  column+=1
  cell+=1 ;

: two
  data@ 2 a:push drop
  column+=1
  cell+=1 ;

: three
  data@ 3 a:push drop
  column+=1
  cell+=1 ;

: four
  data@ 4 a:push drop
  column+=1
  cell+=1 ;

: five
  data@ 5 a:push drop
  column+=1
  cell+=1 ;

: six
  data@ 6 a:push drop
  column+=1
  cell+=1 ;

: seven
  data@ 7 a:push drop
  column+=1
  cell+=1 ;

: eight
  data@ 8 a:push drop
  column+=1
  cell+=1 ;

: nine
  data@ 9 a:push drop
  column+=1
  cell+=1 ;

[ ' newline , ' cr , ' zero , ' zero , ' one , ' two ,
  ' three , ' four , ' five , ' six , ' seven , ' eight , ' nine ] constant actions

: load  \ s -- a
  init-vars
  f:open
  repeat
    f:getc null? not if
      chars swap ' n:= a:indexof nip
      null? if
        1 "column" t:@ "line" t:@ "Impossible character on line: %d at column: %d" s:strfmt t:err!
        2drop drop null false ;;
      then
      actions caseof
      "cell" t:@ 81 n:> if
        2 "Can't fit to the Sudoku grid." t:err!
        2drop null false ;;
      then
    else
      drop
    then
    f:eof? not
  while! drop
  "cell" t:@ 81 n:= not if
    3 "Not enough values to fill the Sudoku grid." t:err!
    null false
  else
    0 "No error, Sudoku loaded!" t:err!
    "data" t:@ true
  then ;

ns

\
\ solver.8th
\
needs array/each-slice


ns?

ns: solver

[  00, 00, 00, 03, 03, 03, 06, 06, 06,
   00, 00, 00, 03, 03, 03, 06, 06, 06,
   00, 00, 00, 03, 03, 03, 06, 06, 06,
   27, 27, 27, 30, 30, 30, 33, 33, 33,
   27, 27, 27, 30, 30, 30, 33, 33, 33,
   27, 27, 27, 30, 30, 30, 33, 33, 33,
   54, 54, 54, 57, 57, 57, 60, 60, 60,
   54, 54, 54, 57, 57, 57, 60, 60, 60,
   54, 54, 54, 57, 57, 57, 60, 60, 60 ] constant top-left-cell

\ Bit number presentations
a:new 2 b:new b:clear a:push ( 2 b:new b:clear swap 1 b:bit! a:push ) 0 8 loop constant posbit

: posbit?  \ n -- b
  posbit swap a:@ nip const ;

: search  \ b -- n
  null swap
  (
    dup -rot b:bit@ if
      rot drop break
    else
      nip
    then
  ) 0 8 loop swap ;

: b-or  \ b b -- b
  ' n:bor b:op ;

: b-and  \ b b -- b
  ' n:band b:op ;

: b-xor  \ b b -- b
  b:xor
  [ xff, x01 ] b:new
  b-and ;

: b-not  \ b -- b
  xff b:xor
  [ xff, x01 ] b:new
  b-and ;

: b-any  \ a -- b
  ' b-or 0 posbit? a:reduce ;

: row \ a row -- a
  9 n:* 9 a:slice ;

: col  \ a col -- a
  -1 9 a:slice+ ;

: -rot9+
  -rot 9 n:+ ;

\ For testing sub boards
: sub  \ a n -- a
  top-left-cell swap a:@ nip over over 3 a:slice
  -rot9+ 2dup 3 a:slice
  -rot9+ 3 a:slice
  a:+ a:+ ;

\ Possible numbers for a cell
: candidates?  \ n -- s
  dup dup 9 n:/ n:int swap 9 n:mod \ row col
  "solver-board" t:@ swap col b-any
  "solver-board" t:@ rot row b-any
  b-or
  "solver-board" t:@ rot sub b-any
  b-or
  b-not ;

: num-of-candidates?  \ b -- n
  0 swap ( b:bit@ rot n:+ swap ) 0 8 loop drop ;

\ If found:     -- n T
\ If not found: -- T
: find-free-cell
  a:new "solver-board" t:@
  (
    tuck a:@ 0 posbit? b:= if
      -rot a:push swap
    else
      nip
    then
  ) 0 80 loop swap nip

  a:len 0 n:= not if
    ( candidates? num-of-candidates? swap candidates? num-of-candidates? n:cmp ) a:sort
    a:pop nip true
  else
    drop
    false
  then ;

: check
  true
  "solver-board" t:@
  ( dup -rot a:@ 0 posbit? b:= not if
      over a:@ >r over 0 posbit? a:! over candidates? r@ b-and 0 posbit? b:= not if
        swap r> a:!
      else
        swap r> a:!
        nip
        false swap
        break
      then
    else
      nip
    then ) 0 80 loop drop ;

: validate
  true
  "solver-board" t:@
  ( dup -rot a:@ swap 2 pick 0 posbit? a:! 2 pick candidates? 2 pick b:= if
      -rot a:!
    else
      2drop drop
      false swap
      break
    then ) 0 80 loop drop ;

: solve
  "solver-board" t:!
  check not if
    false ;;
  then
  a:new "history" t:!
  repeat
    find-free-cell if
      dup candidates?
      repeat
        search null? if
          drop "solver-board" t:@ -rot a:! drop
          "history" t:@ a:len 0 n:= if
            drop false ;;
          then
          a:pop nip
          a:open
        else
          n:1+ posbit?
          dup
          "solver-board" t:@ 4 pick rot a:! drop
          b-xor
          2 a:close
          "history" t:@ swap a:push drop
          break
        then
      again
    else
      validate
      break
    then
  again ;

ns

\
\ sudoku.8th
\
needs nk/gui
needs nk/widgets
needs nk/keyboard
needs gui/filebrowser

libbin font/Roboto-Regular.ttf

"loader.8th" f:include
"solver.8th" f:include

: secs
  d:ticks d:ticks/sec n:/ ;

a:new ( 0 solver:posbit? a:push ) 81 times var, gui-board

: new-win
  {
    name: "main",
    wide: 460,
    high: 560,
    resizable: false,
    fonts: {
      f1: {
        font: @font/Roboto-Regular.ttf
      }
    },
    fontheight: 24,
    font: "f1",
    title: "Sudoku Solver"
  }
  nk:win ;

: centered \ rect s font  --  rect' s font
  2dup nk:measure-font swap 2 a:close >r
  rot nk:rect-center nip r@ \ s font p1 dim
  ( -2 n:/ ) a:map ' n:+ a:2map
  r> a:+ -rot ;

: center-rect  \ r1 r2 -- r3
  nk:rect>size >r
  dup nk:rect>pos
  swap
  nk:rect>size r@
  ( n:- 2 n:/ ) a:2map
  ' n:+ a:2map
  r> a:+ ;

[ @scan:UP , @scan:DOWN , @scan:LEFT , @scan:RIGHT , @scan:0 , @scan:1 , @scan:2 , @scan:3 , @scan:4 , @scan:5 , @scan:6 , @scan:7 , @scan:8 , @scan:9 ] constant NUMBERKEYS

: key-state-changed?   \  s a -- a
  nk:scancode?
  ( if 1 else 0 then ) a:map over nk:get over ?:
  rot 2 pick nk:set
  ( n:cmp ) a:2map ;

: *9
  9 n:* ;

: /9
  over 9 n:/ n:int ;

: 9mod+
  9 n:mod n:+ ;

: rotdropswap
  rot drop swap ;

: up
  /9 n:1- 0 8 n:clamp 9 n:*
  2 pick 9mod+
  rotdropswap ;

: down
  /9 n:1+ 0 8 n:clamp 9 n:*
  2 pick 9mod+
  rotdropswap ;

: left
  /9 *9
  2 pick 9 n:mod n:1- 0 8 n:clamp n:+
  rotdropswap ;

: right
  /9 *9
  2 pick 9 n:mod n:1+ 0 8 n:clamp n:+
  rotdropswap ;

: number?  \ -- n | null
  null "keystates" NUMBERKEYS key-state-changed?
  (
    swap a:pop 1 n:= if
      break rot drop
    else
      nip
    then
  ) 4 2 pick a:len nip n:1- loop-
  over null? if
    drop
    (
      1 n:= if
        [ ' up , ' down , ' left , ' right ] caseof
      else
        drop
      then
    ) a:each drop
  else
   2drop
    4 n:-
  then ;

: cell-hovered-select?  \ n1 n2 rect -- n
  dup [ 0, 0, -8, -8 ] ' n:+ a:2map center-rect
  dup nk:hovered? if
    dup dup 0 1 "black" nk:stroke-rect
    nk:BUTTON_LEFT swap false nk:clicked? if
      -rot over null? if
        drop nip dup rot
      else
        over n:= not if
          nip dup
        else
          drop null swap
        then
        rot
      then
      ' noop nk:do
    then
  then
  -rot over null? not if
    n:= if
      swap 0 3 "black" nk:stroke-rect
    else
      nip
    then
  else
    2drop nip
  then ;

: generate-grid  \ w h xoffs yoffs -- a
  a:new ( >r ( 5 pick n:* 3 pick n:+ r@ 5 pick n:* 3 pick n:+ 6 pick 6 pick 4 a:close a:push ) 0 8 loop rdrop ) 0 8 loop
  nip nip nip nip ;

var solver-task-id

"" var, message
true var, input-enabled

50 constant CELL-WIDTH
50 constant CELL-HEIGHT
5 constant X-OFFS
100 constant Y-OFFS

var start-time

CELL-WIDTH CELL-HEIGHT X-OFFS Y-OFFS generate-grid constant SUDOKU-GRID

: sudoku-grid  \ n | null -- n | null
  SUDOKU-GRID
  ( dup 0 "white" nk:fill-rect
    dup 0 1 "black" nk:stroke-rect
    dup 2 pick gui-board @ swap a:@ nip solver:search nip null? not if        \ if bit is set
      [ "1","2", "3", "4", "5", "6", "7", "8", "9" ] swap caseof
    else \ no bits set
      drop ""
    then
    "f1" centered "white" "black" nk:draw-text
    input-enabled @ if    \ input is enabled if solver task is not running
      cell-hovered-select?
    else
      2drop
    then
  ) a:each drop ;

: draw-subgrid-borders   \ w h xoffs yoffs --
  3 pick 3 n:* 2 pick n:+ over 2 a:close dup 0 6 pick 9 n:* 2 a:close ' n:+ a:2map 3 "black" nk:stroke-line
  3 pick 6 n:* 2 pick n:+ over 2 a:close dup 0 6 pick 9 n:* 2 a:close ' n:+ a:2map 3 "black" nk:stroke-line
  over 4 pick  3 n:* 2 pick n:+ 2 a:close dup 4 pick 9 n:* 0 2 a:close ' n:+ a:2map 3 "black" nk:stroke-line
  over 4 pick  6 n:* 2 pick n:+ 2 a:close dup 4 pick 9 n:* 0 2 a:close ' n:+ a:2map 3 "black" nk:stroke-line
  2drop 2drop ;

: solver-ok
  solver-task-id @ t:result nip const gui-board !
  secs start-time @ n:- "Sudoku solved in %f seconds!" s:strfmt message !
  true input-enabled ! ;

: solver-fail
  "No solution!" message !
  true input-enabled ! ;

: solver-task
  solver:solve if
   "solver-board" t:@
    ' solver-ok nk:do
  else
    ' solver-fail nk:do
  then ;

: start-solver-task
  false input-enabled !
  "selected" null nk:set
  "Working..." message !
  secs start-time !
  gui-board @ const 1 ' solver-task t:task-n solver-task-id ! ;

: clear-board
  gui-board @ a:clear ( 0 solver:posbit? a:push ) 81 times drop ;

: main-render
  {
    title: "test",
    padding: [4,4],
    flags: [ @nk:WINDOW_NO_SCROLLBAR ],

    \ for the filebrowser
    chosen: null,
    showing: false,
    restrict: false,
    fb: {
      root: @getcwd ,
      rowheight: 24 ,
      multi: false ,
      filter: ["*.txt"]
    }
  }
  nk:begin
    "showing" nk:get input-enabled @ and if
      nk:win-high 1 nk:layout-row-dynamic
        ["fb","restrict"] get a:open if "top" getcwd m:! then g:filebrowser null? if drop else
          if
            \ user chose something, an array is on TOS
            a:len 0 n:= not if
              a:pop dup "chosen" swap set
              loader:load if
                ( solver:posbit? a:push ) a:each! drop gui-board !
                "Sudoku loaded succesfully!" message !
              else
                drop
                t:err? "msg" m:@ nip message !
              then
            else
              drop
            then
          else
            "chosen" null nk:set
          then
          "showing" false nk:set
        then
    else
      nk:get-row-height 3 nk:layout-row-dynamic
        "Load" ( input-enabled @ if "showing" true nk:set then ) nk:button-label
        "Clear" ( input-enabled @ if clear-board "" message ! then ) nk:button-label
        "Solve" ( input-enabled @ if start-solver-task then ) nk:button-label
      nk:get-row-height 1 nk:layout-row-dynamic
        message @ 50 nk:EDIT_SIMPLE nk:EDIT_READ_ONLY n:bor nk:PLUGIN_FILTER_DEFAULT nk:edit-string 2drop
      "selected" nk:get sudoku-grid "selected" swap nk:set
      CELL-WIDTH CELL-HEIGHT X-OFFS Y-OFFS draw-subgrid-borders
      "selected" nk:get null? not if
        number? null? not input-enabled @ and if
          solver:posbit? gui-board @ -rot a:! drop
          ' noop nk:do
        else
          drop
          dup "selected" nk:get n:= not if
            "selected" swap nk:set
            ' noop nk:do
          else
            drop
          then
        then
      else
        drop
      then
    then
  nk:end ;

: app:main
  new-win ' main-render -1 nk:render-loop ;