Logic games in APL: Hitori

Source code

⍝ NOTE: This version is still under development.

'pco' ⎕CY 'dfns'

⍝ --- Logic Games Library ---
filter ← {⍵/⍨⍺⍺¨⍵}
filter_valid_pos ← {(∧/1∘≤,≤∘⍺) filter ⍵}

gen ← {⍺←0 ⋄ ⍺⍴⍨⍵⍴⍨2⌈≢⍵}

fill ← {⍺@⍵⊢⍺⍺}
mul_fill ← {0=≢⍵: ⍬ ⋄ ⍺ (⍺⍺ fill)∘⊆¨⍵}

COLS ← (¯1 0)(0 1)(1 0)(0 ¯1)
DIAG ← (¯1 1)(1 1)(1 ¯1)(¯1 ¯1)
DIRS ← COLS (,,⍤0) DIAG

adj ← {⍺←1 ⋄ ⍺⍺ filter_valid_pos ⍵+DIRS/⍨(2|⍺)=⍺⌊8⍴1 0}
⍝ --- End Logic Games Library ---

solver ← {
  q_adj ← s⍴2∘(s adj)∘⊂¨,⍳s←⍴⍵

  (q_adj q_solver) ⍵
}

q_solver ← {
  m ← ⍵
  q_adj ← ⍺⍺

  ⍝ Find repeated numbers in rows
  g←⊃⊂∨.=⊂⌽⍨¨⍳∘(1-⍨≢)

  ⍝ Differentiate repeated numbers in rows (m1) and column (m2)
  primes ← 1↓{⍵,4 pco ¯1↑⍵}⍣(≢m)⊢ ≢m

  m1←primes×⍤¯1⊢m×g m
  m2←primes×⍤1⊢m×⍉g ⍉m

  ⍝ Position of repeated numbers grouped
  b←⊃,/{((1,2≠/⊢)∘{⍵[⍋⍵]}⊂((⍸0≠⍵)⌷⍨∘⊂⍋))0~⍨,⍵}¨m1 m2

  ⍝ For each row/column with repeated numbers, list all combinations of
  ⍝ cells to try to delete in order to keep only unique numbers in that
  ⍝ row/column.
  b←{⍵∘~¨⊂¨⍵}¨b

  ⍝ Since I'm assuming that I'm adding a black cell in a valid solution,
  ⍝  I cannot add two of them and use the same check function, so I blacken a
  ⍝  cell at a time.
  t_f ← {⍺ {⍵/⍨⍥,⍺ (q_adj check)¨ ⍤¯1 ⊢⍵} ⍺∘.{0@⍺⊢⍵}⍵}
  f ← {⊃,/,⍺∘.{⊃,/t_f / (⊂¨¨⊂¨⍺),⊂⊂⍵}⍵}
  ∪⊃,/f/(⌽b),⊂⊂m
}

check ← {
  q_adj ← ⍺⍺

  ∧/0=,⍵: 0

  ⍝ Check that there aren't two orthogonally adjacent black cells.
  1∊(⍵⍷⍨⍪0 0)∨0 0⍷⍵: 0

  ⍝ Initialized before each check
  num_borders ← 0

  ⍝ Checks if the last blackened cell doesn't isolate a group of white cells.
  ⍝ Traverse the black cells starting from the last blackenend one,
  ⍝  throught the diagonally adjacent cells.
  ⍝ A group of white cells is isolated if the line touches the border
  ⍝  two times or if it re-touches the starting cell.
  sub_check ← {
    lp cp ← ⍺ ⍝ Last Position and Current Position
    sp ← ⍺⍺   ⍝ Starting Position

    ⍝ Dyagonally adjacent numbers to current cell
    near ← ⊃cp⌷q_adj

    ⍝ Update the number of borders touched by the line.
    num_borders +← 4≠⍴near

    ⍝ If the line touches the border twice, the solution isn't valid.
    2=num_borders: 0

    ⍝ Keep only the next blackened cell of the line, except the starting position.
    nxt ← (⊂lp)~⍨near/⍨0=near⌷¨⊂⍵

    ⍝ If the only adjacent cell is the last position, it means that I reached
    ⍝  the end of the line. I've already saved the number of boreders touched,
    ⍝  in case I'm actually in a border, and I can actually exit.
    0=≢nxt: 1

    ⍝ If the starting cell is one of the next ones, I reached a loop, grouping
    ⍝  some white cells inside. So the solution isn't valid.
    sp∊nxt: 0

    ⍝ Recurse on each next blackened cell.
    ⍝ nxt ∧.(⊢∇⍨cp,⍥⊆⊣) ⊂⍵
    ((⊂cp),⍥⊂¨nxt) ∧.∇ ⊂⍵
  }

  ⍺ ∧.{
    num_borders ⊢← 0

    (0 0,⍥⊂⍺) ((⊂⍺) sub_check) ⍵
  } ⊂⍵
}

creator ← {
  n←⍵

  ⍝ Precompute the adjacent cells for each position,
  ⍝   to speed up the check function.
  q_adj ← s⍴2∘(s adj)∘⊂¨,⍳s←n n

  x ← ⌈.5×n
  min max ← x × x - 2 0
  n_z ← 1-⍨min+?1+max-min

  ⍝ Create a boolean mask with a maximum of ⍺ zeros, by placing a 0 in a
  ⍝  random position and marking out the cells around with a ¯1,
  ⍝  until there's no more space or it placed the required number of zeros.
  mask ← 0≠{
    n←≢m←⍵

    p ← (?⍤≢⊃⊢)⍸1=m
    pp ← (n n adj) ⊂p
    ¯1@pp⊢0@(⊂p)⊢m
  }⍣{(~1∊⍺)∨(n_z=+/0=,⍺)}⊢ 1 gen n

  ⍝ Random matrix with unique values in rows and columns
  mat ← 1+n|∘.+⍨?⍨n

  inp ← {⊃(2?n)~⍵}¨@(⊆⍸~mask)⊢mat

  res ← (q_adj q_solver) inp

  fix ← {
    inp ← ⍵
    res ← solver inp

    1=≢res: inp           ⍝ already unique
    0=≢res: inp           ⍝ no solution — needs mask-level fix, give up

    s1 s2 ← 2↑res

    ⍝ Find a cell that is black in s1 but white in s2
    cell ← ⊃{
      diff ← ⍸(0=s1)>0=s2
      0=≢diff: (⍸(0=s1)>0=s2) ⊣ s2 s1⊢←s1 s2
      diff
    } ⍬

    ⍝ Values in the same row/col as cell in s2
    row2 ← (⊃cell)⌷s2
    col2 ← (2⊃cell)⌷⍤1⊢s2

    ⍝ Pick a value that creates a conflict in s2, keeping s1 valid
    candidates ← (row2∪col2)~(0,cell⌷inp)

    0=≢candidates: inp

    ((?∘≢⊃⊢)candidates)@(⊂cell) ⊢ inp
  }

  r_inp ← fix⍣n⊢ inp
  r_res ← solver r_inp

  1=≢r_res: (⊂r_inp),r_res

  ∇⍵
}