[Haskell-cafe] Re: Haskell Logo Voting has started!

[Wolfgang Jeltsch]

Am Mittwoch, 18. März 2009 03:22 schrieb Robin Green:
> I'm afraid it is entirely terminal-based (i.e. text only), so it doesn't
> show the pictures.

Hmm, this doesn’t help me since I’ve already written a terminal-based app. See 
attachement. However, no guarantees that this app works as intended. The 
preferences shown by the app are currently meant to stand for better logos if 
they are lower. So 1 is the winner, not 113.

Well, the terminal-based app is still not enough for me since it’s way too 
time-consuming to always lookup the pictures. You should have a GUI showing 
the pictures and allowing you to select the better one of a pair by a single 
click.

Best wishes,
Wolfgang
-------------- next part --------------
module Main (

    main

) where

    import List hiding (sort)

    main :: IO ()
    main = do
               putStr "Number of items: "
               itemCount <- fmap read getLine
               sorted <- sort (\val1 val2 -> do
                                                 putStr $ "Is "           ++
                                                          show val1       ++
                                                          " better than " ++
                                                          show val2       ++
                                                          "? "
                                                 initAnswer <- getLine
                                                 getDecision initAnswer)
                              [1..itemCount]
               putStr $ unlines [show val ++ " has preference " ++ show rank |
                                 (val,rank) <- sortBy (\(val1,rank1)
                                                        (val2,rank2) -> compare val1 val2) $
                                               zip sorted [1..itemCount]]

    getDecision :: String -> IO Bool
    getDecision "n" = return False
    getDecision "y" = return True
    getDecision _   = do
                          putStr "Illegal answer. Try again. "
                          answer <- getLine
                          getDecision answer

    sort :: (Monad monad) => (val -> val -> monad Bool) -> [val] -> monad [val]
    sort compare []    = return []
    sort compare [val] = return [val]
    sort compare vals  = let

                             (part1,part2) = dissociate vals

                         in do
                                sorted1 <- sort compare part1
                                sorted2 <- sort compare part2
                                merge compare sorted1 sorted2

    dissociate :: [val] -> ([val],[val])
    dissociate []                   = ([],[])
    dissociate [val]                = ([val],[])
    dissociate (val1 : val2 : vals) = let

                                          (subpart1,subpart2) = dissociate vals

                                      in (val1 : subpart1,val2 : subpart2)

    merge :: (Monad monad) => (val -> val -> monad Bool) -> [val] -> [val] -> monad [val]
    merge compare []             []             = return []
    merge compare vals1          []             = return vals1
    merge compare []             vals2          = return vals2
    merge compare (val1 : vals1) (val2 : vals2) = do
                                                      before <- compare val1 val2
                                                      if before
                                                          then do
                                                                   subresult <- merge compare
                                                                                      vals1
                                                                                      (val2 : vals2)
                                                                   return (val1 : subresult)
                                                          else do
                                                                   subresult <- merge compare
                                                                                      (val1 : vals1)
                                                                                      vals2
                                                                   return (val2 : subresult)