|
|
|
@@ -1,178 +0,0 @@
|
|
|
|
|
module Main where
|
|
|
|
|
|
|
|
|
|
import Control.Monad (when, forM_)
|
|
|
|
|
import Control.Monad.State (StateT, execStateT, get, put, modify, lift)
|
|
|
|
|
import Data.Array.IO
|
|
|
|
|
import Data.List (find, sortBy)
|
|
|
|
|
import System.Environment (getArgs)
|
|
|
|
|
import System.IO (hSetEcho, hSetBuffering, stdin, stdout, BufferMode(NoBuffering), hFlush)
|
|
|
|
|
import System.Random (randomRIO)
|
|
|
|
|
import System.Exit (exitSuccess)
|
|
|
|
|
|
|
|
|
|
-- Types of user choices
|
|
|
|
|
data Verdict = GoLeft | GoRight deriving (Eq, Show)
|
|
|
|
|
data Preference = Choice Verdict | GoBack | QuitNow deriving (Eq, Show)
|
|
|
|
|
data Comparison = Comp String String Verdict deriving (Show)
|
|
|
|
|
|
|
|
|
|
-- The application state
|
|
|
|
|
data AppState = AppState
|
|
|
|
|
{ items :: [String]
|
|
|
|
|
, history :: [Comparison]
|
|
|
|
|
, original :: [String]
|
|
|
|
|
} deriving (Show)
|
|
|
|
|
|
|
|
|
|
-- Initialize the state
|
|
|
|
|
initialState :: [String] -> AppState
|
|
|
|
|
initialState xs = AppState { items = xs, history = [] , original = xs }
|
|
|
|
|
|
|
|
|
|
-- Tails gets trolled by the type system
|
|
|
|
|
tails :: [a] -> [[a]]
|
|
|
|
|
tails [] = [[]]
|
|
|
|
|
tails xs@(_:xs') = xs : tails xs'
|
|
|
|
|
|
|
|
|
|
-- helper function for arrays
|
|
|
|
|
newArrayFrom :: [a] -> IO (IOArray Int a)
|
|
|
|
|
newArrayFrom xs = newListArray (0, length xs - 1) xs
|
|
|
|
|
|
|
|
|
|
-- O(n) Fisher-Yates shuffle
|
|
|
|
|
shuffle :: [a] -> IO [a]
|
|
|
|
|
shuffle xs = do
|
|
|
|
|
let n = length xs
|
|
|
|
|
if n < 2
|
|
|
|
|
then return xs
|
|
|
|
|
else do
|
|
|
|
|
arr <- newArrayFrom xs
|
|
|
|
|
forM_ [n - 1, n - 2 .. 1] $ \i -> do
|
|
|
|
|
j <- randomRIO (0, i)
|
|
|
|
|
vi <- readArray arr i
|
|
|
|
|
vj <- readArray arr j
|
|
|
|
|
writeArray arr j vi
|
|
|
|
|
writeArray arr i vj
|
|
|
|
|
getElems arr
|
|
|
|
|
|
|
|
|
|
-- Read a single key, handling arrow keys
|
|
|
|
|
getKey :: IO Preference
|
|
|
|
|
getKey = do
|
|
|
|
|
hSetEcho stdin False
|
|
|
|
|
c <- getChar
|
|
|
|
|
hSetEcho stdin True
|
|
|
|
|
case c of
|
|
|
|
|
'\ESC' -> do
|
|
|
|
|
_c2 <- getChar
|
|
|
|
|
c3 <- getChar
|
|
|
|
|
case c3 of
|
|
|
|
|
'D' -> putStrLn "←" >> return (Choice GoLeft)
|
|
|
|
|
'C' -> putStrLn "→" >> return (Choice GoRight)
|
|
|
|
|
_ -> getKey
|
|
|
|
|
'b' -> putStrLn "b" >> return GoBack
|
|
|
|
|
'q' -> putStrLn "q" >> return QuitNow
|
|
|
|
|
'h' -> putStrLn "←" >> return (Choice GoLeft)
|
|
|
|
|
'l' -> putStrLn "→" >> return (Choice GoRight)
|
|
|
|
|
'k' -> putStrLn "b" >> return GoBack
|
|
|
|
|
_ -> getKey
|
|
|
|
|
|
|
|
|
|
-- The shared comparison function that tracks history
|
|
|
|
|
compareItems :: String -> String -> StateT AppState IO Verdict
|
|
|
|
|
compareItems x y = do
|
|
|
|
|
lift $ putStr $ x ++ " vs. " ++ y ++ " (←/→/b/q): "
|
|
|
|
|
lift $ hFlush stdout
|
|
|
|
|
choice <- lift getKey
|
|
|
|
|
case choice of
|
|
|
|
|
Choice GoLeft -> do
|
|
|
|
|
modify (\s -> s { history = Comp x y GoLeft : history s })
|
|
|
|
|
return GoLeft
|
|
|
|
|
Choice GoRight -> do
|
|
|
|
|
modify (\s -> s { history = Comp x y GoRight : history s })
|
|
|
|
|
return GoRight
|
|
|
|
|
GoBack -> handleBack
|
|
|
|
|
QuitNow -> lift $ exitSuccess
|
|
|
|
|
|
|
|
|
|
-- Handle going back
|
|
|
|
|
handleBack :: StateT AppState IO Verdict
|
|
|
|
|
handleBack = do
|
|
|
|
|
s <- get
|
|
|
|
|
case history s of
|
|
|
|
|
(Comp x y _ : rest) -> do
|
|
|
|
|
put $ s { history = rest }
|
|
|
|
|
compareItems x y
|
|
|
|
|
[] -> do
|
|
|
|
|
lift $ putStrLn "No more history to go back to. Restarting..."
|
|
|
|
|
put $ s { history = [] }
|
|
|
|
|
compareItems (items s !! 0) ( items s !! 1 )
|
|
|
|
|
|
|
|
|
|
-- Check transitive closure
|
|
|
|
|
isLessThan :: [Comparison] -> String -> String -> Bool
|
|
|
|
|
isLessThan hist x y
|
|
|
|
|
| x == y = False
|
|
|
|
|
| otherwise = go [x] []
|
|
|
|
|
where
|
|
|
|
|
go [] _ = False
|
|
|
|
|
go (z:zs) visited
|
|
|
|
|
| z == y = True
|
|
|
|
|
| z `elem` visited = go zs visited
|
|
|
|
|
| otherwise = case filter (\(Comp a _ _) -> a == z) hist of
|
|
|
|
|
[] -> go zs (z:visited)
|
|
|
|
|
comps -> any (\(Comp _ b p) -> p == GoLeft && go (b:zs) (z:visited)) comps
|
|
|
|
|
|| go zs (z:visited)
|
|
|
|
|
|
|
|
|
|
-- Compare function using history
|
|
|
|
|
compareWithHistory :: [Comparison] -> String -> String -> Ordering
|
|
|
|
|
compareWithHistory hist x y
|
|
|
|
|
| x == y = EQ
|
|
|
|
|
| isLessThan hist x y = LT
|
|
|
|
|
| isLessThan hist y x = GT
|
|
|
|
|
| otherwise = case find (\(Comp a b _) -> (a == x && b == y) || (a == y && b == x)) hist of
|
|
|
|
|
Just (Comp a _ GoLeft) -> if a == x then LT else GT
|
|
|
|
|
Just (Comp a _ GoRight) -> if a == x then GT else LT
|
|
|
|
|
Nothing -> EQ
|
|
|
|
|
|
|
|
|
|
-- Sort by prompting user for missing comparisons
|
|
|
|
|
sortPref :: [String] -> StateT AppState IO [String]
|
|
|
|
|
sortPref xs = do
|
|
|
|
|
s <- get
|
|
|
|
|
let hist = history s
|
|
|
|
|
allPairs = [(x, y) | (x:ys) <- tails xs, y <- ys]
|
|
|
|
|
missingPairs = filter (\(x, y) -> not (isLessThan hist x y || isLessThan hist y x)) allPairs
|
|
|
|
|
mapM_ (\(x, y) -> compareItems x y >> return ()) missingPairs
|
|
|
|
|
s' <- get
|
|
|
|
|
return $ sortBy (compareWithHistory (history s')) xs
|
|
|
|
|
|
|
|
|
|
-- Display the sorted results
|
|
|
|
|
displayResult :: [String] -> IO ()
|
|
|
|
|
displayResult xs = do
|
|
|
|
|
putStrLn "\nSorted Result:"
|
|
|
|
|
mapM_ (\(i, item) -> putStrLn $ show i ++ ". " ++ item) $ zip [1 :: Int ..] xs
|
|
|
|
|
|
|
|
|
|
-- Ask user if they want to save the results
|
|
|
|
|
askToSave :: [String] -> IO ()
|
|
|
|
|
askToSave xs = do
|
|
|
|
|
putStr "Would you like to save the sorted list? (y/n) "
|
|
|
|
|
hFlush stdout
|
|
|
|
|
response <- getChar
|
|
|
|
|
putStrLn ""
|
|
|
|
|
when (response == 'y' || response == 'Y') $ do
|
|
|
|
|
putStr "Enter filename to save: "
|
|
|
|
|
hFlush stdout
|
|
|
|
|
filename <- getLine
|
|
|
|
|
writeFile filename (unlines xs)
|
|
|
|
|
putStrLn $ "Sorted list saved to " ++ filename
|
|
|
|
|
|
|
|
|
|
-- Main function
|
|
|
|
|
main :: IO ()
|
|
|
|
|
main = do
|
|
|
|
|
hSetBuffering stdout NoBuffering
|
|
|
|
|
hSetBuffering stdin NoBuffering
|
|
|
|
|
args <- getArgs
|
|
|
|
|
case args of
|
|
|
|
|
[filename] -> do
|
|
|
|
|
content <- readFile filename
|
|
|
|
|
let ls = lines content
|
|
|
|
|
when (null ls) $ do
|
|
|
|
|
putStrLn "No items to sort."
|
|
|
|
|
exitSuccess
|
|
|
|
|
shuffled <- shuffle ls
|
|
|
|
|
finalState <- execStateT (sortPref shuffled >>= \sorted -> modify (\s -> s { items = sorted })) (initialState shuffled)
|
|
|
|
|
let sortedList = items finalState
|
|
|
|
|
displayResult sortedList
|
|
|
|
|
askToSave sortedList
|
|
|
|
|
_ -> putStrLn "Usage: h2h_sorter [filename]"
|
