-- !!! Brute force soln to a puzzle. Sent to us by Stephen Eldridge
module Main(main) where

data ItemType = Bono
              | Edge
              | Larry
              | Adam
              deriving (Eq, Ord, Enum)

data BankType = LeftBank
              | RightBank
              deriving Eq

data StateType = State {bonoPos :: BankType,
                        edgePos :: BankType,
                        larryPos :: BankType,
                        adamPos :: BankType}
                 deriving Eq

type History = [(Int, StateType)]

type Solutions = [History]

initialState, finalState :: StateType
initialState = State LeftBank LeftBank LeftBank LeftBank
finalState = State RightBank RightBank RightBank RightBank

position :: ItemType -> StateType ->  BankType
position Bono = bonoPos
position Edge = edgePos
position Larry = larryPos
position Adam = adamPos

updateState :: StateType -> ItemType -> BankType -> StateType
updateState state Bono pos = state {bonoPos = pos}
updateState state Edge pos = state {edgePos = pos}
updateState state Larry pos = state {larryPos = pos}
updateState state Adam pos = state {adamPos = pos}

opposite :: BankType -> BankType
opposite LeftBank = RightBank
opposite RightBank = LeftBank

notSeen :: StateType -> History -> Bool
notSeen state = all (\(_, s) -> state /= s)

writeItem :: ItemType -> BankType -> ShowS
writeItem Bono LeftBank
  = showString "    Bono |                    |\n"
writeItem Edge LeftBank
  = showString "The Edge |                    |\n"
writeItem Larry LeftBank
  = showString "   Larry |                    |\n"
writeItem Adam LeftBank
  = showString "    Adam |                    |\n"
writeItem Bono RightBank
  = showString "         |                    | Bono\n"
writeItem Edge RightBank
  = showString "         |                    | The Edge\n"
writeItem Larry RightBank
  = showString "         |                    | Larry\n"
writeItem Adam RightBank
  = showString "         |                    | Adam\n"

writeState :: StateType -> ShowS
writeState state
  = showString "----------------------------------------\n"
  . writeItem Bono (bonoPos state)
  . writeItem Edge (edgePos state)
  . writeItem Larry (larryPos state)
  . writeItem Adam (adamPos state)
  . showString "----------------------------------------\n"

totalTime :: History -> Int
totalTime ((time, _) : _) = time

writeHistory :: History -> ShowS
writeHistory [ ] = id
writeHistory history
  = foldr
    (\(time, state) acc ->
       showString "Time: "
     . shows (total - time)
     . showChar '\n'
     . writeState state . acc) id history
     where
       total = totalTime history

minSolutions :: Solutions -> Solutions
minSolutions [ ] = [ ]
minSolutions (history : next)
  = reverse (minAcc (totalTime history) [history] next)
      where
        minAcc minSoFar mins [ ] = mins
        minAcc minSoFar mins (history : next)
          = case compare minSoFar total of
              LT -> minAcc minSoFar mins next
              EQ -> minAcc minSoFar (history : mins) next
              GT -> minAcc total [history] next
            where
              total = totalTime history

writeSolutions :: Solutions -> Int -> ShowS
writeSolutions [ ] _ = id
writeSolutions (item : next) count
  = showString "Solution " . shows count . showChar '\n'
  . writeHistory item
  . writeSolutions next (succ count)

u2times :: ItemType -> Int
u2times Bono = 10
u2times Edge = 5
u2times Larry = 2
u2times Adam = 1

transfer :: StateType -> StateType -> BankType -> Int -> History -> Solutions

-- We are trying to get from a legal state, source, to another legal
-- state and history tells us one way to do it in time countdown
-- starting from dest where the torch is at location.
-- If we find newDest from which we can get to dest in one step
-- we can find all the solutions recursively.

transfer source dest location countdown history
  | source == dest
    = [(countdown, dest) : history]
  | otherwise
    = moveOne ++ moveTwo
        where
          newHistory = (countdown, dest) : history
          newLocation = opposite location

          moveOne = concat
                    [transfer
                       source newDest
                       newLocation newTime newHistory

                    | item <- [Bono .. Adam],
                      position item dest == location,
                      let newDest = updateState dest item newLocation,
                      notSeen newDest history,
                      let newTime = countdown + u2times item]

          moveTwo = concat
                    [transfer
                       source newDest
                       newLocation newTime newHistory

                    | i <- [Bono .. Larry],
                      j <- [succ i .. Adam],
                      position i dest == location &&
                      position j dest == location,
                      let
                        newDest
                          = updateState
                              (updateState dest i newLocation)
                              j newLocation,
                      notSeen newDest history,
                      let newTime = countdown + u2times i]


main :: IO ( )
main
  = putStr (writeSolutions mins 1 "")
      where
        solutions
          = transfer initialState finalState
                     RightBank 0 [ ]
        mins = minSolutions solutions