1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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 <a href="/cdn-cgi/l/email-protection" class="__cf_email__" data-cfemail="a3c0e3">[email protected]</a>(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 (,)

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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)

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
10. 10

sel :: Int -> Int -> Expr
sel i n = lam [pvar "x"] (caseE (var "x") [alt])
where alt :: Match
alt = simpleM pat rhs
pat :: Patt
pat = ptup (map pvar as)
rhs :: Expr
rhs = var (as !! (i-1)) -- !! is 0 based
as :: [String]
as = ["a"++show i | i <- [1..n] ]

1. 1

http://rosettacode.org/mw/index.php?title=MD5/Implementation&diff=166456&oldid=164374

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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

module Main where

import Control.Monad
--import Data.Monoid

data State s a = State (s -> (a, s))

runState :: State s a -> s -> (a, s)
runState (State f) = f

instance Monad (State s) where
			return a = State $ \s -> (a, s)
			ma >>= mf = State $ \s0 -> let (b, s1) = runState ma s0 
				in runState (mf b) s1

type FSM s = State s s 

fsm :: (ev -> s -> s) -> (ev -> FSM s)
fsm transition = \e -> State $ \s -> (s, transition e s)

data PN = NONZ | PONZ | POPZ | NOPZ deriving (Eq,Show)

parse :: Int -> FSM PN
parse = fsm $ trans 
	where trans 1 NONZ= PONZ
	      trans 1 NOPZ= POPZ
	      trans 1 POPZ= NOPZ
	      trans 1 PONZ= NONZ
	      trans 0 POPZ= PONZ
	      trans 0 PONZ= POPZ
	      trans 0 NONZ= NOPZ
	      trans 0 NOPZ= NONZ
	      
conv [] = []
conv ('1':xs) = 1:(conv xs)
conv ('0':xs) = 0:(conv xs)
conv (_:xs) = error "parse error"

main =do
	x <- getLine
	print $ (snd $ runState (mapM parse (conv x)) POPZ) == POPZ
	print $ runState (mapM parse (conv x)) POPZ

1. 1
2. 2

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

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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)

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]

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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!"

1. 1
2. 2
3. 3
4. 4
5. 5
6. 6
7. 7
8. 8
9. 9
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