{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} module Queens where -- The queens problem made famous by Wirth. import Debug.Hoed import Data.List import Test.QuickCheck import Data.Maybe import Test.QuickCheck import Test.QuickCheck.Property import Test.QuickCheck.Gen import Test.QuickCheck.Random import Properties import Types test1 :: IO () test1 = do (HoedAnalysis _ ct) <- runO' defaultHoedOptions (print \$ queens 5) -- TODO compare ct with a stored version to do regression testing return () doit :: IO () doit = testOwp properties (prop_queens_set queens) 8 queens :: Int -> [Board] queens = observe "queens" (\n -> valid n n) -- How can we place m queens on an n*n board? valid :: Int -> Int -> [Board] valid = observe "valid" valid' valid' 0 _ = [B []] valid' m n -- A correct definition: = filter safe (extend n (valid (m-1) n)) -- A defective definition: -- = filter safe (extend n (valid (m-1) (n-1))) extend :: Int -> [Board] -> [Board] extend = observe "extend" (\n bs -> consEach [1..n] bs) consEach :: [Int] -> [Board] -> [Board] consEach = observe "consEach" consEach' consEach' [] bs = [] consEach' (a:x) bs = map (\(B b) -> B (a:b)) bs ++ consEach x bs safe :: Board -> Bool safe = observe "safe" safe' safe' (B (a:b)) = no_threat a (B b) 1 no_threat :: Int -> Board -> Int -> Bool no_threat = observe "no_threat" no_threat' no_threat' a (B []) m = True no_threat' a (B (b:y)) m -- A correct definition: -- = a /= b && a+m /= b && a-m /= b && no_threat a (B y) (m+1) -- A defective definition: = a+m /= b && a-m /= b && no_threat a (B y) (m+1) -------------------------------------------------------------------------------- -- demonstrating the need for parallel equality configurations :: Int -> [Configuration] configurations n = zipWith (\i b -> Configuration i (B b)) [1..] (configurations' n [1..n]) configurations' :: Int -> [Int] -> [[Int]] configurations' n xs | n > 0 = [x:t | x <- xs, t <- configurations' (n-1) xs] | n <= 0 = [[]] queensFilter :: [Configuration] -> [Configuration] queensFilter = observe "queensFilter" queensFilter' queensFilter' (Configuration i b:t) | safe b = Configuration i b : t | otherwise = t doit2 :: IO () doit2 = printOwp properties2 (b1,b2) where ((Configuration _ b1) : (Configuration _ b2) : _) = queensFilter cs cs = (Configuration 1 (B [1,1,1,1])) : (Configuration 2 (B [2,4,1,3])) : [(Configuration 3 (B [1,1,1,1]))] -------------------------------------------------------------------------------- showBoard :: Board -> String showBoard = observe "showBoard" showBoard' showBoard' (B b) = let rank r qcol = map line ["o o o", " \\|/ ", " === "] where line crown_slice = concat (zipWith square [1..] b) where square scol _ = if scol == qcol then crown_slice else if scol `rem` (2::Int) == r `rem` (2::Int) then "....." else " " in unlines (concat (zipWith rank [1..] b))