1. Haskell / Говнокод #17746

    −99

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    --Поиск минимальной выпуклой оболочки
    import Data.List; import Data.Ord
    --общие функции и типы
    data Point = P{x::Float,y::Float}
    	deriving (Show,Eq) 
    	
    getRotate a b c = baX * cbY - baY * cbX
    	where baX = x b - x a; baY = y b - y a;
    		  cbX = x c - x b; cbY = y c - y b;
    		 
    sortFunc a b c 
    	|k < 0  = LT
    	|k == 0 = compare (long a c) (long a b) 
    	|k > 0  = GT
    		where k = getRotate a b c
    
    long a b = (x b - x a)*(x b - x a) + (y b - y a)*(y b - y a)
    		
    getLeftPoint = minimumBy (comparing x)
    --Джарвис
    getMBOJarvis l = mboJ fp l fp
    	where fp = getLeftPoint l		
    		
    mboJ current list fp 
    	|getRotate current next fp > 0   = []
    	|True                            = current : mboJ next listWOC fp
    		where listWOC = filter ((/=)current) list;
    			  next    = minimumBy (sortFunc current) listWOC;
    --Грехем			
    getMBOGragam = tail.throwGraham.sortGraham 
    
    sortGraham list = fp:sortBy (sortFunc fp) list
    	where  fp = getLeftPoint list
    		   
    throwGraham (f:s:t) = mboG (s:f:[]) t
    		   
    mboG fs@(f:s:st) sn@(h:t)
    	|sortFunc s f h == GT = mboG (s:st) sn
    	|True                 = mboG(h:fs) t
    	
    mboG fs@(f:st) sn@(h:t)   = mboG(h:fs) t
    	
    mboG l [] = l
    --тесты		     
    testList1 = [P 0 (-1), P (-1) 0, P 0 1,P 1 0,P (-0.5) (-0.5),P 0.5 (-0.5),P (-0.5) 0.5,P 0.5 0.5,P 0 0]
    		  
    testList2 = [P 0 0, P 1 0, P 0 1,P 2 0,P 1 1,P 0 2,P 2 1,P 1 2,P 2 2]
    	
    	
    testJ1  = mapM_ print $ getMBOJarvis testList1		
    		
    testG1  = mapM_ print $ getMBOGragam testList1
    
    testJ2  = mapM_ print $ getMBOJarvis testList2		
    		
    testG2  = mapM_ print $ getMBOGragam testList2

    Haskell
    [сарказм]
    Как я могу идти против моды - не заливать этих французских лаб и не выпивать чаю?

    Выкладываю, что бы порадовать своего кота Барсика. Барсик, покойся с миром.

    А спонсор этого говна - компания "Потролль препода". "Потролль препода" - пиши лабы на хаскелле
    [/сарказм]

    kegdan, 07 Марта 2015

    Комментарии (28)
  2. Haskell / Говнокод #16405

    −81

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    map_of_enemy :: [[Int]] -> [[Int]]
    map_of_enemy [] = []
    map_of_enemy list = (iniciar (0) (0) (list))
    
    iniciar :: Int -> Int -> [[Int]] -> [[Int]]
    iniciar a b list = if(a == (length list)-1) then [rango a 0 list]
                   else [rango a 0 list]++[(iniciar (a+1) 0 list)]
    
    rango :: Int -> Int -> [[Int]] -> [Int]
    rango a b list = if (b==(length list)-1 && (((list!!a!!0)==(list!!b!!0)) &&     ((list!!a!!1)==(list!!b!!1)) && ((list!!a!!2)==(list!!b!!2))))
                 then [0]
                 else if (b==(length list)-1 && (((list!!a!!0)/=(list!!b!!0)) || ((list!!a!!1)/=(list!!b!!1)) || ((list!!a!!2)/=(list!!b!!2))))
                 then (rango2 a (list!!b) list)
                 else if (((list!!a!!0)==(list!!b!!0)) && ((list!!a!!1)==(list!!b!!1)) && ((list!!a!!2)==(list!!b!!2)))
                 then [0]++(rango a (b+1) list)
                 else (rango2 a (list!!b) list)++(rango a (b+1) list)
    
    rango2 :: Int -> [Int] -> [[Int]] -> [Int]
    rango2 a b list = if ((verif [(list!!a!!0)+(list!!a!!2),(list!!a!!1)+(list!!a!!2)] [(list!!a!!0)-(list!!a!!2),(list!!a!!1)-(list!!a!!2)] (b))) then [1]
                  else [0]
    
    verif a b c = if (((c!!0) < (a!!0)) && ((c!!0) > (b!!0)) && ((c!!1) < (a!!1)) && ((c!!1) > (b!!1))) then True
              else if (((c!!0) < (a!!0)) && ((c!!0) == (b!!0)) && ((c!!1) < (a!!1)) && ((c!!1) == (b!!1))) then True
              else if (((c!!0) == (a!!0)) && ((c!!0) > (b!!0)) && ((c!!1) == (a!!1)) && ((c!!1) > (b!!1))) then True
              else False

    Haskell
    OMG mode on

    kegdan, 22 Июля 2014

    Комментарии (7)
  3. Haskell / Говнокод #15821

    −107

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    import System.Exit
    import Graphics.UI.GLUT
    import Control.Monad
    import Control.Applicative
    import Control.Arrow
    import Control.Concurrent
    import Graphics.Rendering.OpenGL 
    import Data.IORef
    import Data.List
    import Data.Maybe
    initial = ((0,0),(0.005,-0.03),(0,0),([(-0.4,-0.9),(-0.4,-0.85),(0.4,-0.85),(0.4,-0.9),(-0.4,-0.9)],(0,0)),liftM2 (,) [-0.9,-0.7..0.9] [0.5,0.7,0.9])
    ws = dzip [(-1,-1),(-1,1),(1,1),(1,-1)] ; r = 0.1 :: GLfloat
    main = initialWindowSize $= Size 777 777 >> initialWindowPosition $= Position 100 100 >> initialDisplayMode $= [DoubleBuffered] >> createWindow "ursula" >> 
    	newIORef initial >>= \ior -> keyboardMouseCallback $= Just (kbd ior) >> displayCallback $= dlay ior >> idleCallback $= Just (anime ior) >> mainLoop
    dlay ior = clearColor $= Color4 1 1 1 1 >> clear [ColorBuffer] >> readIORef ior >>= drawDoxyq >> swapBuffers
    kbd _ (Char 'q') Down _ _ = exitWith ExitSuccess			
    kbd s (Char x) Down _ _   = modifyIORef' s $ \(a,b,t,(d,e),cs) -> (a,b,t,(d,(if x == '[' then -0.05 else if x == ']' then 0.05 else fst e,0)),cs)
    kbd _ _ _ _ _ = return ()
    draw c = renderPrimitive c . mapM_ (vertex . uncurry Vertex2)
    touch xy s xy' = guard ((xy ==== xy') <= r+r && (s .*. (xy.-.xy')) <= 0) >> Just (xy.-.xy')
    drawDoxyq ((x,y),_,(t,_),(bd,_),cs) = currentColor $= Color4 0.3 0.4 0.8 0 >> mapM_ (mapM_ (draw LineLoop) . sta) cs >> 
    	currentColor $= Color4 0.7 0.1 0.2 1 >> mapM_ (draw LineStrip) swa >> currentColor $= Color4 0 0 0 1 >> draw Polygon bd  where
    	swa = [[(x,y),(x + r/1.8*cos (th+pi/4),y + r/1.8*sin (th+pi/4)),(x + r/1.2*cos th,y + r/1.2*sin th)] | th <- [t,t+pi/2..t+1.6*pi]]
    	sta (x,y) = [[(x,y+r/2),(x-r/2,y-r/2),(x+r/2,y-r/2)],[(x+r/2,y+r/2-0.03),(x-r/2,y+r/2-0.03),(x,y-r/2-0.03)]]
    frame (xy,v,(tt,tr),(b,s),cs) = if snd xy <= r-0.99 || null cs then error "GAME OVER" else (xy.+.v',v',(tt+tr',tr'),(b',s'),cs') where 
    	v' = listy v (\us -> rV (2*negv v .>. foldl1' (.+.) us + tr/11) $ negv v) $ mapMaybe (cutSect xy v) (ws ++ dzip b') ++ mapMaybe (touch xy v) cs
    	s' = 0.93 *. if any ((1<=) . (*signum (fst s)) . fst) b then negv s else s
    	b' = map (.+.s') b ; cs' = filter (isNothing . touch xy v) cs
    	tr' = if v .=. v' then tr else (v' .>. v)/19
    listy d f x = if null x then d else f x
    rV t (x,y) = (x*cos t - y*sin t,y*cos t + x*sin t)
    anime ior = modifyIORef' ior frame >> threadDelay 30000 >> postRedisplay Nothing
    cutSect xy s c@(u,v) = guard (xy ./ l <= r && w `oncut` c && (s .*. (xy.-.w)) <= 0) >> Just (xy.-.w) where 
    	l = ln u (u.-.v) ; w = xy .-| l
    oncut u (v,w) = 0 <= (u.-.v) .*. (w.-.u) && 0 <= (u.-.w) .*. (u.-.w) && ((u.-.w) .<>. (v.-.w)) # 0
    ln xy w = (snd w,-fst w,w.<>.xy)
    (x,y) .-| (a,b,c) = ((b^2*x - a*c - a*b*y)/(a^2 + b^2),-(b*c + a*b*x - a^2*y)/(a^2 + b^2))
    p ./ ln = p ==== p .-| ln ; pop f (a,b) (c,d) = (f a c,f b d)		
    (.+.) = pop (+) ; (.-.) = pop (-)  ; (.=.) = (uncurry (&&) .) . pop (#) 
    (*.) = tmap . (*) ; (.*.) = (uncurry (+) .) . pop (*)
    (.<>.) = (uncurry (-) .) . (. uncurry (flip (,))) . pop (*) ; v .>. u = atan2 (v .<>. u) (v .*. u) 
    norm = sqrt . join (.*.) ; a ==== b = norm $ a.-.b ; negv = tmap negate
    infix 4 #,*. ; infix 3 .+.,==== ; infix 8 .>.
    x # y = abs (x-y) < 0.00001 ; tmap = join (***)
    dzipWith = (<*> drop 1) . zipWith ; dzip = dzipWith (,)

    Вся суть выразительности Haskell

    jkhne4pijgberg, 22 Апреля 2014

    Комментарии (26)
  4. Haskell / Говнокод #14343

    −83

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    setRegState :: RegisterStates -> M_Register -> Word8 -> RegisterStates
    setRegState rs r n =
      let (a, b, c, d, e, f, h, l, pc, sp) = rs in
      case r of
        M_A -> (n, b, c, d, e, f, h, l, pc, sp)
        M_B -> (a, n, c, d, e, f, h, l, pc, sp)
        M_C -> (a, b, n, d, e, f, h, l, pc, sp)
        M_D -> (a, b, c, n, e, f, h, l, pc, sp)
        M_E -> (a, b, c, d, n, f, h, l, pc, sp)
        M_F -> (a, b, c, d, e, n.&.0xF0, h, l, pc, sp)
        M_H -> (a, b, c, d, e, f, n, l, pc, sp)
        M_L -> (a, b, c, d, e, f, h, n, pc, sp)

    Haskell has no boilerplate.
    Из исходников заброшенного эмулятора GameBoy (https://github.com/bitc/omegagb/)

    Yuuri, 10 Января 2014

    Комментарии (8)
  5. Haskell / Говнокод #12738

    −96

    1. 1
    2. 2
    instance Show (a -> b)
    main = print (*)

    http://liveworkspace.org/code/17QAgf$23
    stderr:
    Stack space overflow: current size 8388608 bytes.
    Use `+RTS -Ksize -RTS' to increase it.

    Возможно это из-за того, что нет реализации show и я написать вменяемую не смогу. Как заставить Haskell сгенерировать для меня show?

    Хочется типа такого:

    {-# LANGUAGE OverlappingInstances, FlexibleInstances, UndecidableInstances, StandaloneDeriving, DeriveFunctor #-}
    deriving instance Show (a -> b)
    main = print (*)

    http://liveworkspace.org/code/17QAgf$21
    http://www.haskell.org/ghc/docs/6.12.1/html/users_guide/deriving.html
    http://www.haskell.org/haskellwiki/GHC/Stand-alone_deriving_declarations

    HaskellGovno, 13 Марта 2013

    Комментарии (14)
  6. Haskell / Говнокод #12262

    −86

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    by :: Int -> [a] -> [[a]]
    by _ [] = []
    by n xs = take n xs: by n (drop n xs)
     
    words2 :: String -> (String, String)
    words2 str = conc $ words str where
        conc (x:xs) = (x, concat xs)
     
    groupTemplates :: String -> [(String, String)]
    groupTemplates xs = map (words2) (lines xs)
     
    decodeOne :: String -> [(String, String)] -> String
    decodeOne _ [] = ""
    decodeOne str (x:xs) | str == fst x = fst x ++ " " ++ snd x ++ "\n"
    decodeOne str (_:xs) = decodeOne str xs
     
    decode :: [String] -> [(String, String)] -> String
    decode bs ts = concat $ map (\b -> decodeOne b ts) bs
     
    main = do
        bits      <- readFile "bits.txt"
        templates <- readFile "templates.txt"
     
        writeFile "out.txt" $ decode (by 4 bits) (groupTemplates templates)

    http://www.cyberforum.ru/haskell/thread723767.html

    Fai, 09 Декабря 2012

    Комментарии (36)
  7. Haskell / Говнокод #12056

    −82

    1. 1
    2. 2
    3. 3
    4. 4
    5. 5
    6. 6
    7. 7
    only :: (Integral nt) => nt -> [Bool]
    only n = [ x `mod` n == 0 | x <- [0..] ]
    
    each :: (Integral nt) => nt -> [a] -> [a]
    each n xs = [ snd x | x <- filter fst $ zip (only n) xs ]
    
    main = do print $ each 2 [1,2,3,4,5,6,7,8,9]

    Haskell. Получение каждого n-го элемента списка.

    Fai, 05 Ноября 2012

    Комментарии (81)
  8. Haskell / Говнокод #11976

    −82

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    12. 12
    13. 13
    14. 14
    15. 15
    16. 16
    17. 17
    18. 18
    19. 19
    20. 20
    21. 21
    22. 22
    23. 23
    24. 24
    25. 25
    26. 26
    27. 27
    28. 28
    29. 29
    30. 30
    31. 31
    32. 32
    33. 33
    34. 34
    35. 35
    36. 36
    37. 37
    38. 38
    39. 39
    40. 40
    41. 41
    42. 42
    43. 43
    44. 44
    45. 45
    46. 46
    47. 47
    48. 48
    49. 49
    50. 50
    51. 51
    52. 52
    53. 53
    54. 54
    55. 55
    56. 56
    57. 57
    58. 58
    59. 59
    60. 60
    61. 61
    62. 62
    63. 63
    64. 64
    65. 65
    66. 66
    67. 67
    68. 68
    69. 69
    70. 70
    71. 71
    72. 72
    73. 73
    74. 74
    75. 75
    {-# LANGUAGE ExistentialQuantification,
                 DeriveDataTypeable,
                 PatternSignatures #-}
    
    import Data.Typeable
    import Control.Concurrent
    import Control.Concurrent.MVar
    import Control.Concurrent.Chan
    
    -- Core data types
    
    data Message = forall t . Typeable t => Message t | StopMessage
        deriving Typeable
    
    data Handler = forall t . Typeable t => Handler (t -> IO ())
    
    
    -- Worker thread
    
    data Worker = Worker (Chan Message) (MVar ())
    
    workerThread :: [Handler] -> Chan Message -> MVar () -> IO ()
    workerThread handlers chan finish = loop where
        loop = do
            message <- readChan chan
            case message of
                StopMessage -> putMVar finish ()
                Message val -> do
                    foldr (tryHandler val) (putStrLn "Unhandled message") handlers
                    loop
        tryHandler val (Handler h) rest = maybe rest h (cast val)
    
    startWorker :: [Handler] -> IO Worker
    startWorker handlers = do
        chan <- newChan
        finish <- newEmptyMVar
        forkIO (workerThread handlers chan finish)
        return $ Worker chan finish
    
    send :: Typeable m => Worker -> m -> IO ()
    send (Worker chan _) message = do
        writeChan chan $ Message message
    
    stopWorker :: Worker -> IO ()
    stopWorker (Worker chan finish) = do
        writeChan chan $ StopMessage
        takeMVar finish
    
    
    -- Some tests
    
    data Test = Test Bool String deriving Typeable
    
    intHandler :: Int -> IO ()
    intHandler val = putStrLn $ "Int: " ++ show (val * 2)
    
    strHandler :: String -> IO ()
    strHandler val = putStrLn $ "String: " ++ reverse val
    
    testHandler :: Test -> IO ()
    testHandler (Test b s) = putStrLn $ "Test: " ++ show b ++ " " ++ show s
    
    main = do
        w <- startWorker [
            Handler intHandler,
            Handler (\(val::Char) -> putStrLn $ "Char: " ++ show val),
            Handler strHandler,
            Handler testHandler]
        send w (5::Int)
        send w False
        send w 'a'
        send w "foo"
        send w (Test True "bar")
        stopWorker w
        putStrLn "Finished!"

    Вот такая вот портянка была написана под влиянием дискуссии с HaskellGovno http://govnokod.ru/11968, и недавней его просьбой рассказать об общении потоков в хаскеле.

    Код запускает тред, в который можно передавать различные сообщения (ограничение только одно - тип сообщения должен быть инстансом тайпкласса Typeable). В треде исполняются указанные хендлеры, каждый из которых ловит свой тип сообщений.

    P.S. Для неимеющих хаскеля, но желающих посмотреть на работу кода: http://ideone.com/OMVamc.

    bormand, 22 Октября 2012

    Комментарии (30)
  9. Haskell / Говнокод #11510

    −79

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    t = 40000 -- количество итераций, чтобы выполнялось примерно 1 миллисекунду
                    -- экспериментальным путем определено, что для ideone'вских машин это значение ~40000
     
    sleep x = (apply (t*x) id x) `seq`
        ("I've waited ~" ++ show x ++ " milliseconds to tell this: 'pipisiunchik'.")
    
    -- apply применяет ф-цию f к x n раз
    apply 0 _ !x = x
    apply !n !f !x = apply (n - 1) f (f x)
     
    main = putStrLn $ sleep 1000

    Спешу представить вам плод моего безделья: чистая ф-ция sleep на Haskell!

    Тесты:
    1sec - http://ideone.com/sLxRx
    3.5sec - http://ideone.com/vn4Fd
    10sec - http://ideone.com/U8s36

    zim, 31 Июля 2012

    Комментарии (16)
  10. Haskell / Говнокод #10205

    −85

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    data (,) a b = (,) a b
        deriving Generic
    data (,,) a b c = (,,) a b c
        deriving Generic
    data (,,,) a b c d = (,,,) a b c d
        deriving Generic
    .......
    data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__
     = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_ l_ m_ n_ o_ p_ q_ r_ s_ t_ u_ v_ w_ x_ y_ z_ a__ b__ c__ d__ e__ f__ g__ h__ i__ j__
        -- deriving Generic
    {- Manuel says: Including one more declaration gives a segmentation fault.

    Вот такая вот реализация туплов:
    http://www.haskell.org/ghc/docs/7.4.1/html/libraries/ghc-prim-0.2.0.0/src/GHC-Tuple.html

    bormand, 05 Мая 2012

    Комментарии (15)