Skip to content

Instantly share code, notes, and snippets.

@mk2
Last active August 29, 2015 14:02
Show Gist options
  • Save mk2/fe9ee4b9776c78f2e919 to your computer and use it in GitHub Desktop.
Save mk2/fe9ee4b9776c78f2e919 to your computer and use it in GitHub Desktop.
N-Queen Problem by Elm using FAKE backtrack method
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment