{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------

import Control.Monad ( forM_ )

--------------------------------------------------------------------------------

-- the data structure
type List a = ([a],[a])

-- Creates an empty list.
-- Time complexity: O(1).
empty :: List a
empty = ([],[])

-- Inserts at front of list.
-- Time complexity: O(1).
insertAtFront :: a -> List a -> List a
insertAtFront e (fs,bs) = (e:fs,bs)

-- Inserts at back of list.
-- Time complexity: O(1).
insertAtBack :: a -> List a -> List a
insertAtBack e (fs,bs) = (fs,e:bs)

-- Deletes at front. Requires list to be non-empty.
-- Returns deleted element and new list.
-- Time complexity: amortized O(N).
deleteAtFront :: List a -> (a, List a)
deleteAtFront ([],[]) = error "deleteAtFront: empty list"
deleteAtFront ([],bs) = (head fs, (tail fs,[])) where fs = reverse bs
deleteAtFront (fs,bs) = (head fs, (tail fs,bs))

-- Returns true iff empty.
-- Time complexity: O(1).
isEmpty :: List a -> Bool
isEmpty (fs,bs) = null fs && null bs

-- Converts the list to a haskell list.
-- Time complexity: O(N).
toHaskellList :: List a -> [a]
toHaskellList (fs,bs) = fs ++ reverse bs

--------------------------------------------------------------------------------

type Values a = [a]
type State a = (List a,[a],[Operation])
type Operation = String
type Remaining = Int
type Result a = ([Operation],[a])

test :: Monad m => Int -> m [Result Int]
test len = runTests [(1::Int)..] [(empty,[],[])] len

runTests :: (Monad m, Show a, Eq a) =>
            Values a -> [State a] -> Remaining -> m [Result a]

runTests _  []             _ = fail "runTests: empty list"

runTests _  (p@(_,hl,os):_) 0 = ifOK p $ return [(reverse os,hl)]

runTests is (p@(sl,hl,os):ps) n = do
  rs <- mapM apply ["if","ib","df"]
  return $ concat rs
  where
  -- execute operation 'insertAtFront'
  apply "if" =
    let i = head is
        p' = (insertAtFront i sl, i:hl, ("insertAtFront "++show i):os)
    in ifOK p' $ runTests (tail is) (p':p:ps) (n-1)

  -- execute operation 'insertAtBack'
  apply "ib" =
    let i = head is
        p' = (insertAtBack i sl, hl ++ [i], ("insertAtBack "++show i):os)
    in ifOK p' $ runTests (tail is) (p':p:ps) (n-1)

  -- execute operation 'deleteAtFront'
  apply "df" =
    case (null hl, isEmpty sl) of
      (True,True) -> return [] -- [(reverse os,hl)]
      (False,False) ->
         let (se,sl') = deleteAtFront sl
             (he,hl') = (head hl, tail hl)
             os' = ("deleteAtFront (return value "++show se++")"):os
             p' = (sl', hl', os')
         in if se == he
             then ifOK p' $ runTests is (p':p:ps) (n-1)
             else fail $ "\nrunTests: wrong element deleted ("++show se++
                          " instead of "++show he++")" ++
                          "\nafter: " ++ show (reverse os')
      (_,_) -> error "runTests: impossible"
  apply _ = error "apply: unknown operation"

ifOK :: (Monad m, Show a, Eq a) => State a -> m b -> m b
ifOK (sl,hl,os) c
  | toHaskellList sl == hl = c
  | otherwise = fail $
    "\nrunTests: invalid state after: " ++ show (reverse os) ++
    "\nsl state: " ++ show sl ++
    " which represents " ++ show (toHaskellList sl) ++
    "\nhl state: " ++ show hl

--------------------------------------------------------------------------------

quietTesting :: Int -> IO ()
quietTesting len = do
  results <- test len
  putStrLn $
    show (length results) ++ " tests of length "++show len++". All successful."

verboseTesting :: Int -> IO ()
verboseTesting len = do
  putStrLn $ "\nRunning tests of length "++show len++".."
  results <- test len
  forM_ results $ \(os,es)->putStrLn $
    "operation sequence " ++ show os ++
    " had result " ++ show es
  putStrLn $ show (length results) ++ " tests. All successful."

main :: IO ()
main = do
  verboseTesting 1
  verboseTesting 2
  putStrLn "\nRunning a lot more tests.."
  forM_ [1..12] quietTesting

--------------------------------------------------------------------------------