diff --git a/README.md b/README.md index fcd792f..a8712b4 100644 --- a/README.md +++ b/README.md @@ -1,13 +1,3 @@ # h2h_sorter -Efficient head-to-head sorter terminal toy, with backtracking in Haskell. - -Purpose-made to rank anime girl casts, but will work on any plaintext source. - -## Building and testing - -```bash -cabal build -# sort the Madoka cast -cabal run h2h_sorter -- meguca.txt -``` +Efficient head-to-head sorter with backtracking in Haskell. Purpose-made to rank anime girl casts, but will work on any plaintext source. \ No newline at end of file diff --git a/h2h-sorter.cabal b/h2h-sorter.cabal deleted file mode 100644 index 9d02529..0000000 --- a/h2h-sorter.cabal +++ /dev/null @@ -1,18 +0,0 @@ -cabal-version: 3.0 -name: h2h-sorter -version: 0.2.0 -synopsis: simple head-to-head sorter with backtracking. -license: GPL-3.0-or-later -license-file: LICENSE -author: hpcdisrespecter -build-type: Simple -extra-doc-files: README.md -executable h2h_sorter - main-is: Main.hs - hs-source-dirs: src - build-depends: base >=4.14 && <5 - , array - , mtl - , random - default-language: Haskell2010 - ghc-options: -Wall -O2 diff --git a/meguca.txt b/meguca.txt deleted file mode 100644 index ad980c7..0000000 --- a/meguca.txt +++ /dev/null @@ -1,5 +0,0 @@ -pink -black -yellow -red -blue diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 index 2a86b67..0000000 --- a/src/Main.hs +++ /dev/null @@ -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]"