N-Queen Problem by Elm using FAKE backtrack method

nqueen.elm

import List (..)
import Graphics.Collage (..)
import Window
import Random
import Debug (log)
import Array

{-
  N-Queenっぽいの
  なんちゃってバックトラック法でとく
  ※ちゃんとしたバックトラック法ではないです
 -}

-- 設定できる値
initialX = 1
initialY = 1
boardWidth = 8
algoFps = 4 -- 1/n秒ごとにアルゴリズムが更新される



xCoords w h =
  concat . repeat h <| [1 .. w]

yCoords w h =
  concat . map (repeat w) <| [1 .. h]

xyCoords w h =
  zip (xCoords w h) (yCoords w h)

-- left down to right top
ldrtCoords w h =
  let xys = xyCoords w h
  in map (\(x, y) -> y - x) xys

-- right down to left top
rdltCoords w h =
  let xys = xyCoords w h
  in map (\(x, y) -> y + x) xys

-- color coords
cCoords w h =
  repeat (w * h) lightGreen

xycCoords f w h =
  zipWith (\(x, y) c -> (x, y, c)) (xyCoords w h) (f w h)

drawRect cellW cellH (x, y, color) =
    let lineStyle = solid color
        shp = rect cellW cellH
        diffXy = (toFloat x * cellW, toFloat y * cellH)
    in filled color shp |> move diffXy

data CellState = Queen | Nothing

type BoardState = {
                    boardW : Float
                  , boardH : Float
                  , cellW : Float
                  , cellH : Float
                  , preX : Float
                  , preY : Float
                  , qXs : [Float]
                  , qYs : [Float]
                  , xyq : [CellState]
                  , status : String
                  , checked : Bool
                  , preSuccess : Bool
                  }

initialBoardState = {
                      boardW = boardWidth
                    , boardH = boardWidth
                    , cellW = 20
                    , cellH = 20
                    , preX = initialX
                    , preY = initialY
                    , qXs = 0 :: []
                    , qYs = 0 :: []
                    , xyq = []
                    , status = ""
                    , checked = True
                    , preSuccess = True
                    }

checkQueen boardState =
  let bw = boardState.boardW
      bh = boardState.boardH
      
      xyq = boardState.xyq
      
      countQueens = foldr (\(xy, q) qn -> if q == Queen then qn + 1 else qn) 0
      
      -- チェッカー関数 nはそれぞれチェックするグループIDを示す
      rowCheck n = filter (\(x, cellState) -> x == n) <| zip (yCoords bw bh) xyq
      colCheck n = filter (\(y, cellState) -> y == n) <| zip (xCoords bw bh) xyq
      ldrtCheck n = filter (\(ldrt, cellState) -> ldrt == n) <| zip (ldrtCoords bw bh) xyq
      rdltCheck n = filter (\(rdlt, cellState) -> rdlt == n) <| zip (rdltCoords bw bh) xyq
      
      checkFn = (>=) 1
      
      -- チェックフラグ
      rowCheck' = all checkFn <| log "row" <| map (countQueens . rowCheck) [1 .. bw]
      colCheck' = all checkFn <| log "col" <| map (countQueens . colCheck) [1 .. bh]
      ldrtCheck' = all checkFn <| log "ldrt" <| map (countQueens . ldrtCheck) [(1 - bw) .. (bw - 1)]
      rdltCheck' = all checkFn <| log "rdlt" <| map (countQueens . rdltCheck) [2 .. (bw + bh)]
      
  in rowCheck' && colCheck' && ldrtCheck' && rdltCheck'

deployQueen boardState =
  let bw = boardState.boardW
      bh = boardState.boardH
      
      preX = boardState.preX
      preY = boardState.preY
      
      nextX x = if x == bw then 1 else clamp 1 bw (x + 1)
      incrY y = clamp 1 bh (preY + 1)
      nextY x y = clamp 1 bh (if (x == bw) && (nextX x == 1) then (y + 1) else y)
      nextXY x y = (nextX x, nextY x y)
      
      preSuccess = boardState.preSuccess
      
      xyq = boardState.xyq
      
      qXs = log "qXs" boardState.qXs
      qYs = log "qYs" boardState.qYs
      
      qx = head qXs
      qy = head qYs
      
      preQx = head . tail <| qXs
      preQy = head . tail <| qYs
      
  in if | preSuccess -> -- クイーンの配置に成功
            { boardState | status <- log "status" "success to deploy queen"
                         , checked <- False
                         , preX <- 1
                         , preY <- (incrY preY)
                         , xyq <- changeXyq Queen bw bh 1 (incrY preY) xyq
                         , qXs <- preX :: qXs
                         , qYs <- preY :: qYs }
        | not preSuccess && preX == bw && qx == bw ->
            { boardState | status <- log "status" "failed to deploy queen and cursor at right edge, and pre queen at right edge"
                         , checked <- False
                         , preX <- nextX preQx
                         , preY <- nextY preQx preQy
                         , qXs <- tail . tail <| qXs
                         , qYs <- tail . tail <| qYs
                         , xyq <- changeXyq Queen bw bh (nextX preQx) (nextY preQx preQy) <|
                                     changeXyq Nothing bw bh preQx preQy <|
                                     changeXyq Nothing bw bh qx qy <|
                                     changeXyq Nothing bw bh preX preY xyq }
        | not preSuccess && preX == bw && qx /= bw ->
            { boardState | status <- log "status" "failed to deploy queen and cursor at right edge"
                         , checked <- False
                         , preX <- nextX qx
                         , preY <- nextY qx qy
                         , qXs <- tail qXs
                         , qYs <- tail qYs
                         , xyq <- changeXyq Queen bw bh (nextX qx) (nextY qx qy) <|
                                     changeXyq Nothing bw bh qx qy <|
                                     changeXyq Nothing bw bh preX preY xyq }
        | otherwise -> -- クイーンの配置に失敗
            { boardState | status <- log "status" "failed to deploy queen"
                         , checked <- False
                         , preX <- nextX preX
                         , preY <- nextY preX preY
                         , xyq <- changeXyq Queen bw bh (nextX preX) (nextY preX preY) <|
                                     changeXyq Nothing bw bw preX preY xyq }

changeXyq cellState bw bh x y xyqs =
  let ix = x - 1
      iy = y - 1
      xyq = Array.fromList xyqs
  in Array.toList <| Array.set (ix + bw * iy) cellState xyq

stepAlgo t boardState =
  let bw = boardState.boardW
      bh = boardState.boardH
      
      checked = boardState.checked
      
      preX = boardState.preX
      preY = boardState.preY
      
      xyq = boardState.xyq
      
      qXs = boardState.qXs
      qYs = boardState.qYs
      
      hasQueen = any (\q -> q == Queen) boardState.xyq
      
  in if | not hasQueen -> log "initial queen" <| { boardState | xyq <- changeXyq Queen bw bh preX preY <| repeat (bw * bh) Nothing
                                                              , qXs <- preX :: qXs
                                                              , qYs <- preY :: qYs }
        | not checked -> { boardState | preSuccess <- checkQueen boardState
                                      , checked <- True }
        | otherwise-> deployQueen boardState

cCoordsCalc boardState w h =
  let xyq = boardState.xyq
      conv cellState =
        case cellState of
          Queen -> lightRed
          Nothing -> lightGreen
  in map conv <| xyq

delta = inSeconds <~ fps algoFps

display (windowW, windowH) boardState =
  collage windowW windowH
    <| map (drawRect boardState.cellW boardState.cellH)
    <| xycCoords (cCoordsCalc boardState) boardState.boardW boardState.boardH

main = display <~ Window.dimensions ~ foldp stepAlgo initialBoardState delta