head_to_head_sorter.hs

module Main where

import Control.Monad (when)
import Control.Monad.State (StateT, execStateT, get, put, modify, gets, lift)
import Data.List (intercalate, find, sortBy)
import System.Environment (getArgs)
import System.IO (hSetEcho, hSetBuffering, stdin, stdout, BufferMode(NoBuffering), hFlush)
import System.Random (randomRIO)
import System.Exit (exitSuccess)
import Data.Maybe (isJust)

-- Types of user choices
data Preference = GoLeft | GoRight | GoBack | QuitNow deriving (Eq, Show)
data Comparison = Comp String String Preference 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'

-- Fisher-Yates shuffle
shuffle :: [a] -> IO [a]
shuffle [] = return []
shuffle xs = do
  i <- randomRIO (0, length xs - 1)
  let (left, (x:right)) = splitAt i xs
  fmap (x:) (shuffle (left ++ right))

-- 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 GoLeft
        'C' -> putStrLn "→" >> return GoRight
        _   -> getKey
    'b' -> putStrLn "b" >> return GoBack
    'q' -> putStrLn "q" >> return QuitNow
    'h' -> putStrLn "←" >> return GoLeft
    'l' -> putStrLn "→" >> return GoRight
    'k' -> putStrLn "b" >> return GoBack
    _   -> getKey

-- The shared comparison function that tracks history
compareItems :: String -> String -> StateT AppState IO Preference
compareItems x y = do
  lift $ putStr $ x ++ " vs. " ++ y ++ " (←/→/b/q): "
  lift $ hFlush stdout
  choice <- lift getKey
  case choice of
    GoLeft -> do
      modify (\s -> s { history = Comp x y GoLeft : history s })
      return GoLeft
    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 Preference
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 b _) -> 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 b GoLeft) -> if a == x then LT else GT
  Just (Comp a b 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..] 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: head_to_head_sorter [filename]"

meguca

pink
black
yellow
red
blue