Broken solution to Daily Programmer Challenge #318. It's basically Bogosort for NBA teams.

nba.hs

import Control.Monad
import Control.Monad.State.Lazy
import Control.Monad.ST

import Data.Array
import Data.Array.ST
import Data.List
import Data.Maybe

import System.IO
import System.Random

-- State transformer that shuffles an STArray using Fisher-Yates
shuffleST :: RandomGen g => Int -> Int -> g -> STArray s Int e -> ST s (STArray s Int e, g)
shuffleST i max rng a = if i >= max
                        then return (a, rng)
                        else do
                            -- Get random j, i <= j <= max
                            let (j, newGen) = randomR (i, max) rng
                            -- Swap a[i] and a[j]
                            ai <- readArray a i
                            aj <- readArray a j
                            writeArray a i aj
                            writeArray a j ai
                            -- Next iteration
                            shuffleST (i+1) max newGen a

-- Functional wrapper around shuffleST
shuffle :: RandomGen g => Array Int Match -> g -> (Array Int Match, g)
shuffle init rng = runST st
    where (min, max) = bounds init
          st = do
              curr <- thaw init
              (finST, newRng) <- shuffleST min max rng curr
              fin <- freeze finST
              return (fin, newRng)

data Team = AtlantaHawks 
          | BostonCeltics 
          | BrooklynNets 
          | CharlotteHornets 
          | ChicagoBulls 
          | ClevelandCavaliers 
          | DallasMavericks 
          | DenverNuggets 
          | DetroitPistons 
          | GoldenStateWarriors 
          | HoustonRockets 
          | IndianaPacers 
          | LosAngelesClippers 
          | LosAngelesLakers 
          | MemphisGrizzlies 
          | MiamiHeat 
          | MilwaukeeBucks 
          | MinnesotaTimberwolves 
          | NewOrleansPelicans 
          | NewYorkKnicks 
          | OklahomaCityThunder 
          | OrlandoMagic 
          | Philadelphia76ers 
          | PhoenixSuns 
          | PortlandTrailBlazers 
          | SacramentoKings 
          | SanAntonioSpurs 
          | TorontoRaptors 
          | UtahJazz 
          | WashingtonWizards deriving (Eq, Ord, Bounded, Enum)

instance Show Team where
    show AtlantaHawks          = "Atlanta Hawks"
    show BostonCeltics         = "Boston Celtics"
    show BrooklynNets          = "Brooklyn Nets"
    show CharlotteHornets      = "Charlotte Hornets"
    show ChicagoBulls          = "Chicago Bulls"
    show ClevelandCavaliers    = "Cleveland Cavaliers"
    show DallasMavericks       = "Dallas Mavericks"
    show DenverNuggets         = "Denver Nuggets"
    show DetroitPistons        = "Detroit Pistons"
    show GoldenStateWarriors   = "Golden State Warriors"
    show HoustonRockets        = "Houston Rockets"
    show IndianaPacers         = "Indiana Pacers"
    show LosAngelesClippers    = "Los Angeles Clippers"
    show LosAngelesLakers      = "Los Angeles Lakers"
    show MemphisGrizzlies      = "Memphis Grizzlies"
    show MiamiHeat             = "Miami Heat"
    show MilwaukeeBucks        = "Milwaukee Bucks"
    show MinnesotaTimberwolves = "Minnesota Timberwolves"
    show NewOrleansPelicans    = "New Orleans Pelicans"
    show NewYorkKnicks         = "New York Knicks"
    show OklahomaCityThunder   = "Oklahoma City Thunder"
    show OrlandoMagic          = "Orlando Magic"
    show Philadelphia76ers     = "Philadelphia 76ers"
    show PhoenixSuns           = "Phoenix Suns"
    show PortlandTrailBlazers  = "Portland Trail Blazers"
    show SacramentoKings       = "Sacramento Kings"
    show SanAntonioSpurs       = "San Antonio Spurs"
    show TorontoRaptors        = "Toronto Raptors"
    show UtahJazz              = "Utah Jazz"
    show WashingtonWizards     = "Washington Wizards"

numTeams = fromEnum (maxBound :: Team) - fromEnum (minBound :: Team) + 1

-- Yes, these definitions allow matches between a team and itself
-- We'll fix this later
infixr 5 :-:
data Match = Team :-: Team deriving (Eq, Ord)

instance Show Match where
    showsPrec d (u :-: v) = showParen (d > match_prec) $
        showsPrec (match_prec+1) u .
        showString " - "           .
        showsPrec (match_prec+1) v
      where match_prec = 5

instance Bounded Match where
    minBound = minBound :-: minBound
    maxBound = maxBound :-: maxBound

instance Enum Match where
    fromEnum (home :-: away) = numTeams * fromEnum home + fromEnum away
    toEnum n = home :-: away
        where home = toEnum (n `div` numTeams)
              away = toEnum (n `mod` numTeams)

-- Does a match contain a particular team?
containsTeam :: Match -> Team -> Bool
(home :-: away) `containsTeam` team = team == home || team == away

-- This is the list of valid matches
validMatch (home :-: away) = home /= away
validMatches = filter validMatch [minBound .. maxBound]
validMatchArray = listArray (1, length validMatches) validMatches

-- Shuffle the list of valid matches
getMatchBag :: RandomGen g => g -> (Array Int Match, g)
getMatchBag = shuffle validMatchArray

-- Now let's go about building the season.
-- We're going to take the matches in a random order and assign them to rounds
-- There are 29 rounds in each half, and two halves
numRoundsPerHalf   = 29

-- Rounds work better as a list rather than an array
-- This will be slightly inefficient but it's okay
type Round  = [Match]
type Season = Array Int Round

-- Helper function for making an array of a single value
constArray :: Ix i => (i, i) -> e -> Array i e
constArray bds = listArray bds . repeat

seasonBounds = (1, 2 * numRoundsPerHalf)
emptySeason = constArray seasonBounds []

-- These functions check each rule for emplacing a match

-- Get a round as it currently exists, as a State monad
-- For convenience, if it's a nonexistant round, return []
getRound :: Int -> State Season Round
getRound rnum 
    | inRange seasonBounds rnum = fmap (! rnum) get
    | otherwise                 = return []

-- Returns Just (home :-: away) if the team played in the given round, Nothing if not
findTeamInRound :: Int -> Team -> State Season (Maybe Match)
findTeamInRound rnum team = do
    round <- getRound rnum
    return $ find (`containsTeam` team) round

-- Returns True if the team played in the given round and was the home team, False if not
teamWasHomeInRound rnum team = do
    maybeMatch <- findTeamInRound rnum team
    case maybeMatch of Just (home :-: _) -> return $ home == team
                       Nothing           -> return False

-- Would this match break the rule on a team playing more than two home games in a row?
breaksConsecutiveHomeLimit :: Int -> Match -> State Season Bool
breaksConsecutiveHomeLimit rnum (home :-: _) = do
    homeM2 <- teamWasHomeInRound (rnum-2) home
    homeM1 <- teamWasHomeInRound (rnum-1) home
    homeP1 <- teamWasHomeInRound (rnum+1) home
    homeP2 <- teamWasHomeInRound (rnum+2) home

    return $ (homeM2 && homeM1) 
          || (homeM1 && homeP1) 
          || (homeP1 && homeP2)

-- Has this team ever played two home games in a row?
teamHasConsecutiveHome :: Team -> State Season Bool
teamHasConsecutiveHome team = do
    let rnumList  = uncurry enumFromTo seasonBounds
        pred rnum = do
            b1 <- teamWasHomeInRound  rnum    team
            b2 <- teamWasHomeInRound (rnum-1) team
            return $ b1 && b2
    consHomes <- filterM pred rnumList
    return . not . null $ consHomes

-- Does this emplacement cause a team to play any set of two consecutive
-- home games?
causesConsecutiveHomePair :: Int -> Match -> State Season Bool
causesConsecutiveHomePair rnum (home :-: _) = do
    homeM1 <- teamWasHomeInRound (rnum-1) home
    homeP1 <- teamWasHomeInRound (rnum+1) home

    return $ homeM1 || homeP1

-- Does this emplacement cause a team to play more than two sets of consecutive
-- home games?
breaksConsecutiveHomePairLimit :: Int -> Match -> State Season Bool
breaksConsecutiveHomePairLimit rnum (home :-: away) = do
    causesHome <- causesConsecutiveHomePair rnum (home :-: away)
    consHome <- teamHasConsecutiveHome home

    return $ causesHome && consHome

-- Now repeat the above four rules for away
-- Returns True if the team played in the given round and was the away team, False if not
teamWasAwayInRound rnum team = do
    maybeMatch <- findTeamInRound rnum team
    case maybeMatch of Just (_ :-: away) -> return $ away == team
                       Nothing           -> return False

-- Would this match break the rule on a team playing more than two away games in a row?
breaksConsecutiveAwayLimit :: Int -> Match -> State Season Bool
breaksConsecutiveAwayLimit rnum (_ :-: away) = do
    awayM2 <- teamWasAwayInRound (rnum-2) away
    awayM1 <- teamWasAwayInRound (rnum-1) away
    awayP1 <- teamWasAwayInRound (rnum+1) away
    awayP2 <- teamWasAwayInRound (rnum+2) away

    return $ (awayM2 && awayM1) 
          || (awayM1 && awayP1) 
          || (awayP1 && awayP2)

-- Has this team ever played two away games in a row?
teamHasConsecutiveAway :: Team -> State Season Bool
teamHasConsecutiveAway team = do
    let rnumList  = uncurry enumFromTo seasonBounds
        pred rnum = do
            b1 <- teamWasAwayInRound  rnum    team
            b2 <- teamWasAwayInRound (rnum-1) team
            return $ b1 && b2
    consAways <- filterM pred rnumList
    return . not . null $ consAways

-- Does this emplacement cause a team to play any set of two consecutive
-- away games?
causesConsecutiveAwayPair :: Int -> Match -> State Season Bool
causesConsecutiveAwayPair rnum (_ :-: away) = do
    awayM1 <- teamWasAwayInRound (rnum-1) away
    awayP1 <- teamWasAwayInRound (rnum+1) away

    return $ awayM1 || awayP1

-- Does this emplacement cause a team to play more than two sets of consecutive
-- away games?
breaksConsecutiveAwayPairLimit :: Int -> Match -> State Season Bool
breaksConsecutiveAwayPairLimit rnum (home :-: away) = do
    causesAway <- causesConsecutiveAwayPair rnum (home :-: away)
    consAway <- teamHasConsecutiveAway away

    return $ causesAway && consAway

-- Does this emplacement cause a team to play in a single round more than once?
breaksRoundPlayLimit :: Int -> Match -> State Season Bool
breaksRoundPlayLimit rnum (t1 :-: t2) = do
    m1 <- findTeamInRound rnum t1
    m2 <- findTeamInRound rnum t2
    return $ isJust m1 || isJust m2

-- Get all rounds for a single half
getRoundsForHalf :: Int -> State Season [Round]
getRoundsForHalf hnum = do
    let rds = case hnum of 1 -> [1                  ..   numRoundsPerHalf]
                           2 -> [numRoundsPerHalf+1 .. 2*numRoundsPerHalf]
                           _ -> error "Bad half number!"
    mapM getRound rds

-- Get the half number for a round number
roundToHalf rnum
    | 1                  <= rnum && rnum <=   numRoundsPerHalf = 1
    | numRoundsPerHalf+1 <= rnum && rnum <= 2*numRoundsPerHalf = 2
    | otherwise                                                = error "Bad round number!"

-- Does this emplacement cause team A to play team B twice in the same half?
breaksHalfPlayLimit :: Int -> Match -> State Season Bool
breaksHalfPlayLimit rnum (t1 :-: t2) = do
    -- Note that there's only once possible target match for this rule
    let targetMatch = t2 :-: t1
        hnum        = roundToHalf rnum
        roundPred   = elem targetMatch
    rds <- getRoundsForHalf hnum
    return $ any roundPred rds

-- Is this emplacement a good idea?
isGoodMatch :: Int -> Match -> State Season Bool
isGoodMatch rnum mt = do
    b1 <- causesConsecutiveHomePair      rnum mt
    b2 <- breaksConsecutiveHomeLimit     rnum mt
    b3 <- breaksConsecutiveHomePairLimit rnum mt
    b4 <- causesConsecutiveAwayPair      rnum mt
    b5 <- breaksConsecutiveAwayLimit     rnum mt
    b6 <- breaksConsecutiveAwayPairLimit rnum mt
    b7 <- breaksRoundPlayLimit           rnum mt
    b8 <- breaksHalfPlayLimit            rnum mt

    return $ (not . or) [b1, b2, b3, b4, b5, b6, b7, b8]

-- Is this emplacement valid at all?
isValidMatch :: Int -> Match -> State Season Bool
isValidMatch rnum mt = do
    b1 <- breaksConsecutiveHomeLimit     rnum mt
    b2 <- breaksConsecutiveHomePairLimit rnum mt
    b3 <- breaksConsecutiveAwayLimit     rnum mt
    b4 <- breaksConsecutiveAwayPairLimit rnum mt
    b5 <- breaksRoundPlayLimit           rnum mt
    b6 <- breaksHalfPlayLimit            rnum mt

    return $ (not . or) [b1, b2, b3, b4, b5, b6]

-- Try to make one emplacement
-- Return True (and put change) if we succeded, False if not
-- Tries to avoid placing two consecutive home or away games, otherwise fails to tryForcedEmplacement
tryEmplacement :: Match -> State Season Bool
tryEmplacement mt = go min
    where (min, max) = seasonBounds
          go rnum
            | rnum > max = tryForcedEmplacement mt
            | otherwise  = do
                good <- isGoodMatch rnum mt
                if not good 
                then go (rnum+1)
                else do
                    -- Make that change to the season, then return True
                    season <- get
                    let round = season ! rnum
                    put $ season // [(rnum, mt:round)]
                    return True

-- Try forcing one emplacement
-- Return True (and put change) if we succeded, False if not
-- (it is possible for this algorithm to get stuck)
tryForcedEmplacement :: Match -> State Season Bool
tryForcedEmplacement mt = go min
    where (min, max) = seasonBounds
          go rnum
            | rnum > max = return False
            | otherwise  = do
                valid <- isValidMatch rnum mt
                if not valid 
                then go (rnum+1)
                else do
                    -- Make that change to the season, then return True
                    season <- get
                    let round = season ! rnum
                    put $ season // [(rnum, mt:round)]
                    return True


-- Try emplacing the whole list recursively
-- Return a Just with the match number on which it failed, or Nothing for success
tryFilling :: Int -> [Match] -> State Season (Maybe Int)
tryFilling _      []       = return Nothing
tryFilling mcount (mt:mts) = do
    res <- tryEmplacement mt
    if res
    then tryFilling (mcount+1) mts
    else return $ Just mcount

-- Print a season
printSeason :: Handle -> Season -> IO ()
printSeason h season = go min
    where (min, max) = seasonBounds
          printRound = foldr ((>>) . print) (hPutStrLn h "")
          go :: Int -> IO ()
          go rnum
            | rnum > max = return ()
            | otherwise  = do
                hPutStrLn h $ "Round " ++ show rnum
                hPutStrLn h ""
                printRound (season ! rnum)
                go (rnum+1  )

main = do
    matchBag <- getStdRandom getMatchBag
    let mlist         = elems matchBag
        (res, season) = runState (tryFilling 1 mlist) emptySeason
    case res of Nothing     -> printSeason stdout season
                Just mcount -> putStrLn ("Failed on match " ++ show mcount ++ ", retrying") >> main