From 8ca4d4f58bc4525278253ddfe817c5337bb28490b875c8d9a56a90b397070d94 Mon Sep 17 00:00:00 2001
From: stephenszwiec <stephen.szwiec@ndsu.edu>
Date: Tue, 14 Jul 2026 19:27:25 -0500
Subject: [PATCH] Provided build in Cabal, scaffolded project.

---
 README.md        |  12 +++-
 h2h-sorter.cabal |  18 +++++
 meguca.txt       |   5 ++
 src/Main.hs      | 178 +++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 212 insertions(+), 1 deletion(-)
 create mode 100644 h2h-sorter.cabal
 create mode 100644 meguca.txt
 create mode 100644 src/Main.hs

diff --git a/README.md b/README.md
index a8712b4..fcd792f 100644
--- a/README.md
+++ b/README.md
@@ -1,3 +1,13 @@
 # h2h_sorter
 
-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
+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 
+```
diff --git a/h2h-sorter.cabal b/h2h-sorter.cabal
new file mode 100644
index 0000000..9d02529
--- /dev/null
+++ b/h2h-sorter.cabal
@@ -0,0 +1,18 @@
+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
new file mode 100644
index 0000000..ad980c7
--- /dev/null
+++ b/meguca.txt
@@ -0,0 +1,5 @@
+pink
+black
+yellow
+red
+blue
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..2a86b67
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,178 @@
+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]"