1. 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 [email protected](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

    Комментарии (34)
  2. 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)
  3. Haskell / Говнокод #12738

    −95

    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)
  4. Haskell / Говнокод #12262

    −85

    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

    Комментарии (40)
  5. 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

    Комментарии (104)
  6. 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

    Комментарии (43)
  7. 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

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

    −84

    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)
  9. Haskell / Говнокод #9598

    −92

    1. 01
    2. 02
    3. 03
    4. 04
    5. 05
    6. 06
    7. 07
    8. 08
    9. 09
    10. 10
    11. 11
    -- | The unit datatype @()@ has one non-undefined member, the nullary
    -- constructor @()@.
    data () = () deriving Generic
    
    data (,) a b = (,) a b
    . . .
    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/latest/html/libraries/ghc-prim-0.2.0.0/src/GHC-Tuple.html#%28%29

    wvxvw, 03 Марта 2012

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

    −357

    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
    chislo :: String -> Bool
    chislo []=True
    chislo (x:xs) =if (x=='1') then chislo xs
                   else if (x=='2') then chislo xs
                     else if (x=='3') then chislo xs
                       else if (x=='4') then chislo xs
                         else if (x=='5') then chislo xs
                           else if (x=='6') then chislo xs
                             else if (x=='7') then chislo xs
                               else if (x=='8') then chislo xs
                                 else if (x=='9') then chislo xs
                                   else if (x=='0') then chislo xs
                                     else if (x=='.') then chislo xs
    							 else False

    haskell

    resettik, 26 Мая 2011

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