\n" ]
30 |
--------------------------------------------------------------------------------
/chase/Chase.hs:
--------------------------------------------------------------------------------
1 | module Chase where
2 |
3 | import Data.Map (Map)
4 | import qualified Data.Map as M
5 | import Data.Array
6 |
7 | import Data.Maybe (mapMaybe,catMaybes)
8 | import Data.List (maximumBy,delete)
9 | import Data.Ord (comparing)
10 |
11 | import Debug.Trace
12 |
13 | -- Colloborate Diffusion
14 | -- http://en.wikipedia.org/wiki/Antiobjects
15 | type Desirability = Double
16 | type Scent = Double
17 | type Point = (Int,Int)
18 |
19 | data Agent = Goal Desirability
20 | | Pursuer
21 | | Path Scent
22 | | Obstacle
23 | deriving (Eq,Show)
24 |
25 | data Environment = Environment {
26 | board :: Map Point [Agent]
27 | , size :: Int
28 | , pursuers :: [Point]
29 | , goal :: Point
30 | } deriving Show
31 |
32 | diffusionRate :: Double
33 | diffusionRate = 0.1
34 |
35 | scent :: Agent -> Scent
36 | scent (Path s) = s
37 | scent (Goal s) = s
38 | scent _ = 0
39 |
40 | zeroScent :: Agent -> Agent
41 | zeroScent (Path s) = Path 0
42 | zeroScent x = x
43 |
44 | zeroScents :: [Agent] -> [Agent]
45 | zeroScents (x:xs) = zeroScent x : xs
46 | zeroScents x = x
47 |
48 | topScent :: [Agent] -> Scent
49 | topScent (x:xs) = scent x
50 | topScent _ = 0
51 |
52 | addPoint :: Point -> Point -> Point
53 | addPoint (x,y) (dx,dy) = (x+dx,y+dy)
54 |
55 | -- |Builds a basic environment
56 | createEnvironment :: Int -> Environment
57 | createEnvironment s = Environment b s [(1,1),(s-1,s-1)] (mx,my)
58 | where
59 | (mx,my) = (s `div` 2, s `div` 2)
60 | b = M.fromList [((x,y),mkAgent x y) | x <- [0..s], y <- [0..s] ]
61 | mkAgent x y | x == 0 || y == 0 || x == s || y == s = [Obstacle]
62 | | x == mx && y == my = [Goal 1000,Path 0]
63 | | x == 1 && y == 1 = [Pursuer, Path 0]
64 | | x == (s-1) && y == (s-1) = [Pursuer,Path 0]
65 | | otherwise = [Path 0]
66 |
67 | update :: Environment -> Environment
68 | update e@(Environment b s _ _) = updatePursuers (e { board = c })
69 | where
70 | c = M.fromList [((x,y), diffusePoint' (x,y) c b) | y <- [0..s], x <- [0..s]]
71 |
72 | -- TODO simplify?
73 | canMove :: Maybe [Agent] -> Bool
74 | canMove (Just (Path _:xs)) = True
75 | canMove _ = False
76 |
77 | flipObstacle :: Point -> Environment -> Environment
78 | flipObstacle p e | head x /= Obstacle = e { board = M.insert p (Obstacle:x) b }
79 | | null (tail x) = e
80 | | otherwise = e { board = M.insert p (tail x) b }
81 | where
82 | b = board e
83 | x = b M.! p
84 |
85 | -- |Hides the scent underneath
86 | flipPursuer :: Point -> Environment -> Environment
87 | flipPursuer p e | head x /= Pursuer = e { board = M.insert p (Pursuer:x) b
88 | , pursuers = p : pursuers e }
89 | | null (tail x) = e
90 | | otherwise = e { board = M.insert p (tail x) b
91 | , pursuers = delete p (pursuers e) }
92 | where
93 | b = board e
94 | x = b M.! p
95 |
96 |
97 |
98 | move :: Map Point [Agent] -> Point -> Point -> Map Point [Agent]
99 | move e src tgt = M.insert src (zeroScents $ tail srcA)
100 | (M.insert tgt (head srcA : e M.! tgt) e)
101 | where
102 | srcA = e M.! src
103 |
104 | moveGoal :: Point -> Environment -> Environment
105 | moveGoal p e | targetSuitable = e { board = move b (goal e) dest
106 | , goal = dest }
107 | | otherwise = e
108 | where
109 | b = board e
110 | dest = addPoint p (goal e)
111 | targetSuitable = canMove $ M.lookup dest b
112 |
113 | updatePursuers :: Environment -> Environment
114 | updatePursuers env = foldl updatePursuer env (pursuers env)
115 |
116 | -- Ensure we only move if there is a better scent available
117 | updatePursuer :: Environment -> Point -> Environment
118 | updatePursuer e p | null n = e
119 | | otherwise = e { board = move b p m
120 | , pursuers = m : delete p (pursuers e) }
121 | where
122 | b = board e
123 | currentScent = topScent (b M.! p)
124 | n = filter (\x -> topScent (b M.! x) >= currentScent ) $
125 | filter (canMove . (`M.lookup` b)) $ neighbouringPoints p -- can simplify here
126 | m = maximumBy (\x y -> comparing (scent . head) (b M.! x) (b M.! y)) n
127 |
128 | diffusePoint' :: Point -> Map Point [Agent] -> Map Point [Agent] -> [Agent]
129 | diffusePoint' p xs originalGrid = diffusePoint (originalGrid M.! p) (neighbours' xs originalGrid p)
130 |
131 | neighbouringPoints :: Point -> [Point]
132 | neighbouringPoints p = map (addPoint p) [(-1,0), (0,-1), (1,0), (0, 1)]
133 |
134 | neighbours' :: Map Point [Agent] -> Map Point [Agent] -> Point -> [Agent]
135 | neighbours' xs m p = map head $ catMaybes [M.lookup (addPoint p (-1, 0 )) xs
136 | ,M.lookup (addPoint p (0 , -1)) xs
137 | ,M.lookup (addPoint p (1 , 0) ) m
138 | ,M.lookup (addPoint p (0 , 1) ) m]
139 |
140 | neighbours :: Map Point [Agent] -> Point -> [Agent]
141 | neighbours m p = map head $ mapMaybe (`M.lookup` m) (neighbouringPoints p)
142 |
143 | diffusePoint :: [Agent] -> [Agent] -> [Agent]
144 | diffusePoint (Path d:r) n = (Path $ diffusedScent d n) : r
145 | diffusePoint p _ = p
146 |
147 | diffusedScent :: Scent -> [Agent] -> Scent
148 | diffusedScent s xs = s + diffusionRate * sum (map (\x -> scent x - s) xs)
--------------------------------------------------------------------------------
/chase/ChaseVis.hs:
--------------------------------------------------------------------------------
1 | module ChaseVis where
2 |
3 | import Chase
4 |
5 | import Graphics.UI.GLUT as G
6 | import System.Exit (exitWith, ExitCode(ExitSuccess))
7 | import Control.Monad (when,unless,forM_,liftM,liftM2,liftM3)
8 | import Data.IORef (IORef, newIORef)
9 |
10 | import Data.Map ((!))
11 | import qualified Data.Map as M
12 | import Debug.Trace
13 |
14 | data State = State {
15 | env :: IORef Environment
16 | , run :: IORef Bool
17 | , heatMap :: IORef Bool
18 | }
19 |
20 | -- Various top-level configuration parameters
21 |
22 | gridSize :: Int
23 | gridSize = 16
24 |
25 | winHeight :: Int
26 | winHeight = 512
27 |
28 | winWidth :: Int
29 | winWidth = 512
30 |
31 | tick :: Int
32 | tick = 25
33 |
34 | sqSize :: GLfloat
35 | sqSize = fromIntegral winHeight / fromIntegral gridSize
36 |
37 | makeState :: IO State
38 | makeState = liftM3 State (newIORef (createEnvironment gridSize)) (newIORef False) (newIORef False)
39 |
40 | color3f :: Color3 GLfloat -> IO ()
41 | color3f = color
42 |
43 | vertex2f :: Vertex2 GLfloat -> IO ()
44 | vertex2f = vertex :: Vertex2 GLfloat -> IO ()
45 |
46 | colorVertex :: Color3 GLfloat -> Vertex2 GLfloat -> IO ()
47 | colorVertex c v = color3f c >> vertex v
48 |
49 | -- Actual logic of environment appears here
50 |
51 | displayFunc :: State -> DisplayCallback
52 | displayFunc s = do
53 | clear [ColorBuffer]
54 | e <- G.get (env s)
55 | _ <- drawGrid e
56 | flush
57 | swapBuffers
58 |
59 | pickColor :: Agent -> Color3 GLfloat
60 | pickColor (Goal s) = Color3 0 0 1
61 | pickColor Pursuer = Color3 0 1 0
62 | pickColor (Path s) = Color3 (realToFrac s / 1000) 0 0
63 | pickColor Obstacle = Color3 1 1 1
64 |
65 | drawGrid :: Environment -> IO ()
66 | drawGrid (Environment g b _ _) = do
67 | let f i = ((fromIntegral i :: GLfloat) * sqSize)
68 | renderPrimitive Quads $ forM_ [(x,y) | x <- [0..b], y <- [0..b]]
69 | (\(i,j) -> mapM (colorVertex (pickColor (head $ g ! (i,j))))
70 | [Vertex2 (f i + x) (f j + y) | (x,y) <- [(0,0),(sqSize,0),(sqSize,sqSize),(0,sqSize)]])
71 | flush
72 |
73 | -- TODO draw a heat map
74 | drawHeatMap :: Environment -> IO ()
75 | drawHeatMap (Environment g b _ _) = do
76 | let f i = ((fromIntegral i :: GLfloat) * sqSize)
77 | renderPrimitive Quads $ forM_ [(x,y) | x <- [0..b], y <- [0..b]]
78 | (\(i,j) -> do
79 | let c1 = Color3 1 1 1
80 | let c2 = Color3 1 0 1
81 | let c3 = Color3 1 0 1
82 | let c4 = Color3 0 1 1
83 | colorVertex c1 (Vertex2 (f i) (f j))
84 | colorVertex c2 (Vertex2 (f i + sqSize) (f j))
85 | colorVertex c3 (Vertex2 (f i + sqSize) (f j + sqSize))
86 | colorVertex c4 (Vertex2 (f i) (f j + sqSize)))
87 | flush
88 |
89 |
90 | timerFunc :: State -> IO ()
91 | timerFunc s = do
92 | e <- G.get (run s)
93 | when e (env s $~ update)
94 | postRedisplay Nothing
95 | addTimerCallback tick (timerFunc s)
96 |
97 | reshapeFunc :: ReshapeCallback
98 | reshapeFunc s@(Size _ height) =
99 | unless (height == 0) $ do
100 | viewport $= (Position 0 0, s)
101 | loadIdentity
102 | ortho2D 0 512 0 512
103 | clearColor $= Color4 0 0 0 1
104 |
105 | keyboardMouseHandler :: State -> KeyboardMouseCallback
106 | keyboardMouseHandler _ (Char 'q') Down _ _ = exitWith ExitSuccess
107 | keyboardMouseHandler s (Char ' ') Down _ _ = run s $~ not
108 | keyboardMouseHandler s (Char 'h') Down _ _ = heatMap s $~ not
109 | keyboardMouseHandler s (Char 'a') Down _ _ = env s $~ update
110 | keyboardMouseHandler s (SpecialKey KeyLeft) Down _ _ = env s $~ moveGoal (-1,0)
111 | keyboardMouseHandler s (SpecialKey KeyRight) Down _ _ = env s $~ moveGoal (1,0)
112 | keyboardMouseHandler s (SpecialKey KeyUp) Down _ _ = env s $~ moveGoal (0,1)
113 | keyboardMouseHandler s (SpecialKey KeyDown) Down _ _ = env s $~ moveGoal (0,-1)
114 | keyboardMouseHandler s (MouseButton LeftButton) Down _ p = env s $~ flipObstacle (convertCoords p)
115 | keyboardMouseHandler s (MouseButton RightButton) Down _ p = env s $~ flipPursuer (convertCoords p)
116 | keyboardMouseHandler _ _ _ _ _ = return ()
117 |
118 | convertCoords :: Position -> (Int,Int)
119 | convertCoords (Position x y) = (truncate (realToFrac x / sqSize),
120 | (gridSize - 1)- truncate (realToFrac y / sqSize))
121 |
122 | main :: IO ()
123 | main = do
124 | _ <- getArgsAndInitialize
125 | initialDisplayMode $= [ DoubleBuffered, RGBAMode ]
126 | initialWindowSize $= Size 512 512
127 | initialWindowPosition $= Position 0 0
128 | _ <- createWindow "Agent Visualization"
129 |
130 | state <- makeState
131 |
132 | displayCallback $= displayFunc state
133 | reshapeCallback $= Just reshapeFunc
134 | keyboardMouseCallback $= Just (keyboardMouseHandler state)
135 |
136 | addTimerCallback tick (timerFunc state)
137 |
138 | mainLoop
--------------------------------------------------------------------------------
/codegolf/WordFreq.hs:
--------------------------------------------------------------------------------
1 | import Data.Map (Map)
2 | import qualified Data.Map as M
3 | import Data.List
4 | import Char
5 | r=replicate;rf=realToFrac;rd=round;wd=words
6 | cim m k=M.insertWith (+) k 1 m
7 | cw s=take 22 $ sl $ foldl cim M.empty (filter (not.(`elem` (wd "the and of to a i it in or is"))) (wd s))
8 | sl m=sortBy (\(_,x) (_,y)-> compare y x) (M.toList m)
9 | dw w=' ':h++concatMap (dwi ww) w
10 | where
11 | n=(snd.head) w
12 | lw=foldl1 max (map (length.fst) w)
13 | ww=rf(80-(lw+3))/rf n
14 | h=r(rd (ww*rf n)) '_' ++ "\n"
15 | dwi ww (w,n)="|"++r(round (rf n*ww))'_'++"| "++w++"\n"
16 | main=interact(dw.cw.map toLower)
--------------------------------------------------------------------------------
/daily-programmer/17-03-2015/RecurrenceRelations.hs:
--------------------------------------------------------------------------------
1 | -- http://www.reddit.com/r/dailyprogrammer/comments/2z68di/20150316_challenge_206_easy_recurrence_relations/
2 | module RecurrenceRelations where
3 |
4 | type Operator = Integer -> Integer
5 | type Expression = String
6 |
7 | createExpression :: Integer -> [Operator] -> Integer
8 | createExpression seed = foldl (\_ x -> x seed) seed
9 |
10 | parse :: Expression -> [Operator]
11 | parse = map toOperator . words
12 |
13 | toOperator :: String -> Operator
14 | toOperator ('*':xs) = (*) (read xs :: Integer)
15 | toOperator ('-':xs) = (-) (read xs :: Integer)
16 | toOperator ('/':xs) = div (read xs :: Integer)
17 | toOperator ('+':xs) = (+) (read xs :: Integer)
18 | toOperator _ = error "Malformed expression"
19 |
20 | recurrence :: Expression -> Integer -> [Integer]
21 | recurrence expr = iterate (flip createExpression $ parse expr)
22 |
23 |
24 |
--------------------------------------------------------------------------------
/daily-programmer/18-03-2015/Irrigation.hs:
--------------------------------------------------------------------------------
1 | module Irrigation where
2 |
3 | import Data.List (maximumBy)
4 | import Data.Ord (comparing)
5 | import Control.Arrow ((&&&))
6 |
7 | type Location = (Int,Int)
8 |
9 | data Sprinkler = Sprinkler
10 | {
11 | location :: Location
12 | , radius :: Int
13 | }
14 |
15 | data CropField = CropField
16 | {
17 | rows :: Int
18 | , columns :: Int
19 | , crops :: [Location]
20 | }
21 |
22 | grid :: CropField -> [Location]
23 | grid c = [(x,y) | x <- [0..rows c], y <- [0..columns c]]
24 |
25 | intDistance :: Location -> Location -> Int
26 | intDistance (x1,y1) (x2,y2) = floor (sqrt (dx*dx + dy*dy))
27 | where
28 | dx = fromIntegral (x1 - x2)
29 | dy = fromIntegral (y1 - y2)
30 |
31 | bestLocation :: CropField -> Int -> Location
32 | bestLocation field radius = fst $ maximumBy (comparing snd) $ map (location &&& score field) sprinklers
33 | where
34 | sprinklers = [Sprinkler loc radius | loc <- grid field]
35 |
36 | score :: CropField -> Sprinkler -> Int
37 | score field sprinkler = killedCrop + length (filter (inRange sprinkler) (crops field))
38 | where
39 | killedCrop = if location sprinkler `elem` crops field then (- 1) else 0
40 |
41 | inRange :: Sprinkler -> Location -> Bool
42 | inRange s p = intDistance l p <= r
43 | where
44 | r = radius s
45 | l = location s
46 |
47 |
--------------------------------------------------------------------------------
/diamond-square/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2014, Jeff Foster
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Jeff Foster nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/diamond-square/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/diamond-square/diamond-square.cabal:
--------------------------------------------------------------------------------
1 | -- Initial diamond-square.cabal generated by cabal init. For further
2 | -- documentation, see http://haskell.org/cabal/users-guide/
3 |
4 | name: diamond-square
5 | version: 0.1.0.0
6 | synopsis: The diamond square algorithm
7 | -- description:
8 | homepage: http://www.fatvat.co.uk
9 | license: BSD3
10 | license-file: LICENSE
11 | author: Jeff Foster
12 | maintainer: jeff.foster@acm.org
13 | -- copyright:
14 | -- category:
15 | build-type: Simple
16 | -- extra-source-files:
17 | cabal-version: >=1.10
18 |
19 | executable diamond-square
20 | main-is: Main.hs
21 | -- other-modules:
22 | -- other-extensions:
23 | build-depends: base >=4.7 && <4.8,
24 | array >= 0.5,
25 | JuicyPixels >= 3.2,
26 | containers >= 0.5.5,
27 | random >= 1.0,
28 | normaldistribution >= 1.1
29 | hs-source-dirs: src/
30 | default-language: Haskell2010
--------------------------------------------------------------------------------
/diamond-square/src/Main.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE NoMonomorphismRestriction #-}
2 | module Main where
3 |
4 | import Codec.Picture
5 | import qualified Data.Map.Strict as M
6 |
7 | import System.Random
8 | import Control.Monad (liftM)
9 | import Control.Arrow ((&&&))
10 | type Point = (Int,Int)
11 |
12 | data Square = Square
13 | {
14 | position :: Point
15 | , size :: Int
16 | , tl :: Double -- Height of top left
17 | , tr :: Double -- Height of top right
18 | , bl :: Double -- Height of bottom left
19 | , br :: Double -- Height of bottom right
20 | } deriving (Show,Eq)
21 |
22 | mkSquare :: Int -> IO Square
23 | mkSquare sz = do
24 | a <- randomRIO(- 0.5, 0.5)
25 | b <- randomRIO(- 0.5, 0.5)
26 | c <- randomRIO(- 0.5, 0.5)
27 | d <- randomRIO(- 0.5, 0.5)
28 | return (Square (0,0) sz a b c d)
29 |
30 | isUnit :: Square -> Bool
31 | isUnit sq = size sq == 1
32 |
33 | move :: Square -> Point -> Square
34 | move sq (x,y) = sq { position = (a+x,b+y) }
35 | where
36 | (a,b) = position sq
37 |
38 | averageHeight :: Double -> Square -> Double
39 | averageHeight eps sq = eps + ((tl sq + tr sq + bl sq + br sq) / 4.0)
40 |
41 | averageTopHeight :: Square -> Double
42 | averageTopHeight sq = (tl sq + tr sq) / 2.0
43 |
44 | averageBottomHeight :: Square -> Double
45 | averageBottomHeight sq = (bl sq + br sq) / 2.0
46 |
47 | averageLeftHeight :: Square -> Double
48 | averageLeftHeight sq = (tl sq + bl sq) / 2.0
49 |
50 | averageRightHeight :: Square -> Double
51 | averageRightHeight sq = (tr sq + br sq) / 2.0
52 |
53 | divide :: Double -> Square -> [Square]
54 | divide eps parent = [
55 | sq { tr = at, br = ah, bl = al } -- top left unchanged
56 | , (move sq (half,0)) { tl = at, bl = ah, br = ar } -- top right unchanged
57 | , (move sq (0,half)) { tr = ah, br = ab, tl = al } -- bottom left unchanged
58 | , (move sq (half,half)) { tl = ah, bl = ab, tr = ar } -- bottom right unchanged
59 | ]
60 | where
61 | half = size parent `div` 2
62 | sq = parent { size = half }
63 | at = averageTopHeight parent
64 | ah = averageHeight eps parent -- height of middle
65 | ab = averageBottomHeight parent
66 | ar = averageRightHeight parent
67 | al = averageLeftHeight parent
68 |
69 | allSubSquares :: (Double -> Square -> [Square]) -> Square -> [Square]
70 | allSubSquares f sq
71 | | isUnit sq = [sq]
72 | | otherwise = concatMap (allSubSquares f) (f 0 sq)
73 |
74 | allSubSquaresPlusPerturbation :: (Double -> Square -> [Square]) -> Square -> IO [Square]
75 | allSubSquaresPlusPerturbation f sq
76 | | isUnit sq = return [sq]
77 | | otherwise = do
78 | let sz = sqrt $ fromIntegral (size sq)
79 | x <- randomRIO (- 0.5,0.5)
80 | liftM concat $ mapM (allSubSquaresPlusPerturbation f) (f (sz * x) sq)
81 |
82 |
83 | imageSize :: Int
84 | imageSize = 512
85 |
86 | grayScale :: Double -> Double -> Double -> Pixel16
87 | grayScale mn mx p = truncate $ 65535 * zeroToOne
88 | where
89 | zeroToOne = (p - mn) / (mx - mn)
90 |
91 | jetMap :: Double -> Double -> Double -> PixelRGB8
92 | jetMap mn mx p = PixelRGB8 (trunc r) (trunc g) (trunc b)
93 | where
94 | trunc c = truncate (c * 255)
95 | (r,g,b) = color $ (p - mn) / (mx -mn)
96 |
97 | -- v is bound between 0 and 1
98 | -- dv is 1
99 | color :: Double -> (Double,Double,Double)
100 | color v
101 | | v < 0.25 = (0,4*v,1)
102 | | v < 0.50 = (0,1,1 + 4 * (0.25 - v))
103 | | v < 0.75 = (4 * (v - 0.5),1,0)
104 | | otherwise = (1,1 + 4 * (0.75 - v),0)
105 |
106 |
107 | generatePlasma :: Pixel a => (Double -> Double -> Double -> a) -> Square -> Image a
108 | generatePlasma pixFunc sq = generateImage f imageSize imageSize
109 | where
110 | minP = maximum $ M.elems pixels
111 | maxP = minimum $ M.elems pixels
112 | f x y = pixFunc minP maxP (M.findWithDefault 0 (x,y) pixels)
113 | pixels = M.fromList $ map (position &&& averageHeight 0) $ allSubSquares divide sq
114 |
115 | generatePlasma2 :: Pixel a => (Double -> Double -> Double -> a) -> Square -> IO (Image a)
116 | generatePlasma2 pixFunc sq = do
117 | sqs <- allSubSquaresPlusPerturbation divide sq
118 | let f x y = pixFunc minP maxP (M.findWithDefault 0 (x,y) pixels)
119 | pixels = M.fromList $ map (position &&& averageHeight 0) sqs
120 | minP = maximum $ M.elems pixels
121 | maxP = minimum $ M.elems pixels
122 | return (generateImage f imageSize imageSize)
123 |
124 | main :: IO ()
125 | main = do
126 | sq <- mkSquare imageSize
127 | img <- generatePlasma2 jetMap sq
128 | let img2 = generatePlasma jetMap sq
129 | writePng "/home/jefff/Desktop/randomC.png" img
130 | writePng "/home/jefff/Desktop/notrandomC.png" img2
131 |
132 |
--------------------------------------------------------------------------------
/dynamicTimeWarping/DynamicTimeWarping.hs:
--------------------------------------------------------------------------------
1 | module DynamicTimeWarping where
2 |
3 | import Data.Array
4 | import Data.Array.ST (runSTArray, newArray, readArray, writeArray)
5 |
6 | import Data.List (minimumBy)
7 | import Data.Ord (comparing)
8 |
9 | import qualified Data.Vector as V
10 |
11 | import Control.Monad (forM_)
12 |
13 | import Data.Word (Word8)
14 | import Codec.BMP
15 | import qualified Data.ByteString as BS
16 |
17 | import System.Random
18 |
19 | intCost :: Int -> Int -> Int
20 | intCost x y = abs (x - y)
21 |
22 | doubleCost :: Double -> Double -> Int
23 | doubleCost x y = floor $ abs (x - y) * 10.0
24 |
25 | dtw :: V.Vector a -> V.Vector a -> (a -> a -> Int) -> Array (Int,Int) Int
26 | dtw x y cost = runSTArray $ do
27 | let n = V.length x
28 | m = V.length y
29 | maxcost = maxBound
30 | d <- newArray ((0,0),(m,n)) 0
31 | forM_ [1..n] (\i -> writeArray d (0,i) maxcost)
32 | forM_ [1..m] (\i -> writeArray d (i,0) maxcost)
33 | forM_ [1..n] $ \i ->
34 | forM_ [1..m] $ \j -> do
35 | let c = cost (x V.! (i -1)) (y V.! (j -1))
36 | insertion <- readArray d (j,i-1)
37 | deletion <- readArray d (j-1,i)
38 | match <- readArray d (j-1,i-1)
39 | writeArray d (j,i) (c + minimum [insertion,deletion,match])
40 | return d
41 |
42 | dtwWin :: V.Vector a -> V.Vector a -> (a -> a -> Int) -> Int -> Array (Int,Int) Int
43 | dtwWin x y cost window = runSTArray $ do
44 | let n = V.length x
45 | m = V.length y
46 | maxCost = maxBound
47 | w = max window (abs (n - m)) -- constrain window size
48 | d <- newArray ((0,0),(m,n)) maxCost
49 | writeArray d (0,0) 0
50 | forM_ [1..n] $ \i ->
51 | forM_ [max 1 (i-w) .. min m (i+w)] $ \j -> do
52 | let c = cost (x V.! (i - 1)) (y V.! (j - 1))
53 | insertion <- readArray d (j,i-1)
54 | deletion <- readArray d (j-1,i)
55 | match <- readArray d (j-1,i-1)
56 | writeArray d (j,i) (c + minimum [insertion,deletion,match])
57 | return d
58 |
59 | render :: Array (Int,Int) Int -> FilePath -> IO ()
60 | render arr file = writeBMP file bmp
61 | where
62 | warpPath = warpingPath arr
63 | (_,(w,h)) = bounds arr
64 | bs = BS.pack (concatMap (normalize minvs maxvs) vs)
65 | bmp = packRGBA32ToBMP w h bs
66 | highlightedPath = (arr // (zip warpPath (repeat (- 1))))
67 | vs = map snd $ filter (\((x,y),_) -> x /= 0 && y /= 0) (assocs highlightedPath)
68 | maxvs = maximum (filter (/= (maxBound :: Int)) vs)
69 | minvs = minimum (filter (/= (- 1)) vs)
70 |
71 | warpingPath :: Array (Int,Int) Int -> [(Int,Int)]
72 | warpingPath arr = go (w,h) []
73 | where
74 | (_,(w,h)) = bounds arr
75 | go p@(x,y) xs
76 | | x == 0 && y == 0 = p : xs
77 | | otherwise = go minVal (minVal : xs)
78 | where
79 | minVal = minimumBy (comparing (arr !)) [down,downLeft,left]
80 | down = (max 0 (x-1),max 0 y)
81 | left = (x,max 0 (y-1))
82 | downLeft = (max 0 (x-1),max 0 (y-1))
83 |
84 | -- http://stackoverflow.com/questions/7706339/grayscale-to-red-green-blue-matlab-jet-color-scale
85 | normalize :: Int -> Int -> Int -> [Word8]
86 | normalize _ _ (- 1) = [255,255,255,255]
87 | normalize minx maxx x = [scale r, scale g, scale b, 0]
88 | where
89 | (r,g,b) = color normalized
90 | scale v = floor (maxB * v)
91 | normalized = delta / rnge
92 | maxB = fromIntegral (maxBound :: Word8)
93 | delta = fromIntegral $ x - minx
94 | rnge = fromIntegral $ maxx - minx
95 |
96 | -- v is bound between 0 and 1
97 | -- dv is 1
98 | color :: Double -> (Double,Double,Double)
99 | color v
100 | | v < 0.25 = (0,4*v,1)
101 | | v < 0.50 = (0,1,1 + 4 * (0.25 - v))
102 | | v < 0.75 = (4 * (v - 0.5),0,1)
103 | | otherwise = (1,1 + 4 * (0.75 - v),1)
104 |
105 |
106 | save :: [Int] -> [Int] -> FilePath -> IO ()
107 | save seq1 seq2 filename = do
108 | let cost = dtw (V.fromList seq1) (V.fromList seq2) intCost
109 | render cost filename
110 |
111 | saveDouble :: [Double] -> [Double] -> FilePath -> IO ()
112 | saveDouble seq1 seq2 filename = do
113 | let cost = dtw (V.fromList seq1) (V.fromList seq2) doubleCost
114 | render cost filename
115 |
116 | saveWin :: [Int] -> [Int] -> Int -> FilePath -> IO ()
117 | saveWin seq1 seq2 w filename = do
118 | let cost = dtwWin (V.fromList seq1) (V.fromList seq2) intCost w
119 | render cost filename
120 |
121 | ts :: Num a => a
122 | ts = 512
123 |
124 | cosInt :: [Int]
125 | cosInt = map (floor . (*10) . cos) [(0.0 :: Double) .. ts]
126 |
127 | sinInt :: [Int]
128 | sinInt = map (floor . (*10). sin) [(0.0 :: Double) .. ts]
129 |
130 | sinIntFast :: [Int]
131 | sinIntFast = map (floor . (*10). sin . (* 0.25)) [(0.0 :: Double) .. ts]
132 |
133 | main :: IO ()
134 | main = do
135 | gen <- getStdGen
136 | let rs = randoms gen
137 | randomX = map (`mod` 256) $ take (2*ts) rs
138 | randomY = map (`mod` 256) $ take (2*ts) (drop (3*ts) rs)
139 | save randomX randomY "random.bmp"
140 | save (replicate 0 ts) (replicate 0 ts) "perfect2.bmp"
141 | saveWin [0..ts] [0..ts] 5 "perfect-win5.bmp"
142 | save [0..ts] [0..ts] "perfect.bmp"
143 | saveWin [0..ts] [ts,ts - 1..0] 5 "opposite-win5.bmp"
144 | save [0..ts] [ts,ts - 1..0] "opposite.bmp"
145 | saveWin [0..ts] [2,4..ts * 2] 5 "double-win5.bmp"
146 | save [0..ts] [2,4..ts * 2] "double.bmp"
147 | save cosInt sinInt "cos-sin.bmp"
148 | save cosInt [0..ts] "cosInt-Linear.bmp"
149 |
150 |
--------------------------------------------------------------------------------
/fluidDynamics/Fluid.hs:
--------------------------------------------------------------------------------
1 | module Fluid where
2 | -- Inspired by http://www.bestinclass.dk/index.php/2010/03/functional-fluid-dynamics-in-clojure/
3 | -- http://github.com/LauJensen/Fluid-Dynamics/raw/master/fluids.clj
4 | -- Navier Stokes (http://en.wikipedia.org/wiki/Navier–Stokes_equations)
5 |
6 | import qualified Data.Vector.Unboxed as V
7 |
8 | import Criterion.Main
9 | import Test.HUnit
10 | import Data.List (foldl')
11 |
12 | type DVector = V.Vector Double
13 |
14 | data Grid = Grid Int DVector deriving (Show,Eq)
15 |
16 | -- |Note that we create some padding to try and simplify the handling of edges
17 | emptyBoard :: Int -> Grid
18 | emptyBoard sz = Grid sz (V.fromList (replicate ((sz+2)*(sz+2)) 0))
19 |
20 | -- |Is a single dimensional array really quicker?
21 | get :: Grid -> (Int,Int) -> Double
22 | get (Grid n b) p = V.unsafeIndex b (ix n p)
23 |
24 | -- |Get the XY given the length of one of the sides
25 | ix :: Int -> (Int,Int) -> Int
26 | ix n (i,j) = i + (n+2) * j where
27 |
28 | addSource :: Grid -> Grid -> Double -> Grid
29 | addSource (Grid n x) (Grid _ s) dt = Grid n (V.zipWith (\x' s' -> x' + dt * s') x s )
30 |
31 | setBnd :: Int -> Grid -> Grid
32 | setBnd b g@(Grid n x) = Grid n (z V.// corners)
33 | where
34 | x'@(Grid _ z) = Grid n (x V.// concat [ [(ix n (0,i), mx * get g (1,i))
35 | ,(ix n (n+1,i), mx * get g (n,i))
36 | ,(ix n (i,0), my * get g (i,1))
37 | ,(ix n (i,n+1), my * get g (i,n))] | i <- [1..n]])
38 | mx | b==1 = -1
39 | | otherwise = 1
40 | my | b==2 = -1
41 | | otherwise = 1
42 | corners = [(ix n (0,0) , 0.5 * (get x' (1,0) + get x' (0,1)))
43 | ,(ix n (0,n+1) , 0.5 * (get x' (1,n+1) + get x' (0,n)))
44 | ,(ix n (n+1,0) , 0.5 * (get x' (n,0) + get x' (n+1,1)))
45 | ,(ix n (n+1,n+1), 0.5 * (get x' (n,n+1) + get x' (n+1,n)))]
46 |
47 | linSolve' :: Int -> Double -> Double -> Grid -> Grid -> Grid
48 | linSolve' b a c g0@(Grid n _) g@(Grid _ gs) = setBnd b result where
49 | result = Grid n (V.foldl' fx gs (V.fromList [(i,j) | i <- [1..n], j <- [1..n]]))
50 | fx us (i,j) = v
51 | where
52 | p = ix n (i,j)
53 | left = ix n (i-1,j)
54 | right = ix n (i+1,j)
55 | down = ix n (i,j-1)
56 | up = ix n (i,j+1)
57 | v = V.unsafeUpd us [(p, (get g0 (i,j) + a * (V.unsafeIndex us left +
58 | V.unsafeIndex us right +
59 | V.unsafeIndex us down +
60 | V.unsafeIndex us up)) /c)]
61 |
62 | linSolve :: Int -> Grid -> Grid -> Double -> Double -> Grid
63 | linSolve b x x0 a c = iterate (linSolve' b a c x0) x !! 20
64 |
65 | diffuse :: Int -> Grid -> Grid -> Double -> Double -> Grid
66 | diffuse b x@(Grid n _) x0 diff dt = linSolve b x x0 a (1+4*a) where
67 | a = dt * diff * fromIntegral (n*n)
68 |
69 | advect :: Int -> Grid -> (Grid,Grid) -> Double -> Grid
70 | advect b d0@(Grid n _) (u,v) dt = setBnd b (Grid n (e V.// [(ix n (i,j),adv i j) | i <- [1..n], j <- [1..n]])) where
71 | dt0 = dt * fromIntegral n
72 | (Grid _ e) = emptyBoard n
73 | adv i j = s0*(t0*get d0 (i0,j0) + t1*get d0 (i0,j1)) +
74 | s1*(t0*get d0 (i1,j0) + t0*get d0 (i1,j1))
75 | where
76 | n5 = fromIntegral n + 0.5
77 | x = min n5 (max 0.5 (fromIntegral i - dt0 * get u (i,j)))
78 | y = min n5 (max 0.5 (fromIntegral j - dt0 * get v (i,j)))
79 | i0 = truncate x
80 | i1 = i0 + 1
81 | j0 = truncate y
82 | j1 = j0 + 1
83 | s1 = x - fromIntegral i0
84 | s0 = 1 - s1
85 | t1 = y - fromIntegral j0
86 | t0 = 1 - t1
87 |
88 | project :: (Grid,Grid) -> ((Grid,Grid),(Grid,Grid))
89 | project (u@(Grid n _),v) = ((setBnd 1 u',setBnd 2 v'),(p,d))
90 | where
91 | d = Fluid.div (u,v)
92 | (Grid _ e) = emptyBoard n
93 | p = linSolve 0 (setBnd 0 (emptyBoard n)) d 1 4
94 | nd = fromIntegral n
95 | u' = Grid n (e V.// [(ix n (i,j), get u (i,j) - 0.5*nd*(get p (i+1,j) - get p (i-1,j))) | i <- [1..n], j <- [1..n]])
96 | v' = Grid n (e V.// [(ix n (i,j), get v (i,j) - 0.5*nd*(get p (i,j+1) - get p (i,j-1))) | i <- [1..n], j <- [1..n]])
97 |
98 | div :: (Grid,Grid) -> Grid
99 | div (u@(Grid n _),v) = setBnd 0 d
100 | where
101 | (Grid _ e) = emptyBoard n
102 | d = Grid n (e V.// [(ix n (i,j),
103 | -0.5 * ((get u (i+1,j) - get u (i-1,j) + get v (i,j+1) - get v (i,j-1)) / fromIntegral n))
104 | | i <- [1..n], j <- [1..n]])
105 |
106 | densStep :: Grid -> Grid -> (Grid,Grid) -> Double -> Double -> (Grid,Grid)
107 | densStep x x0 (u,v) diff dt = (advect 0 x'' (u,v) dt,x'')
108 | where
109 | x' = addSource x x0 dt
110 | x'' = diffuse 0 x x' diff dt
111 |
112 | velStep :: (Grid,Grid) -> (Grid,Grid) -> Double -> Double -> (Grid,Grid)
113 | velStep (u,v) (u0,v0) dt visc = (u00,v00)
114 | where
115 | u' = diffuse 1 u (addSource u u0 dt) visc dt
116 | v' = diffuse 2 v (addSource v v0 dt) visc dt
117 | ((u'',v''),(x,y)) = project (u',v') -- u0 and v0 correct
118 | u''' = advect 1 x (u'',v'') dt
119 | v''' = advect 2 y (u'',v'') dt
120 | ((u00,v00), (p,div)) = project (u''',v''')
121 |
122 |
123 | main = defaultMain [
124 | bgroup "test" [
125 | bench "linsolvestep" $ whnf linsolveStep g
126 | ,bench "linsolvewhole" $ whnf linsolveT 5
127 | ]
128 | ]
129 | where
130 | g = emptyBoard 10
131 | linsolveStep = linSolve' 4 5.0 6.0
132 | linsolveT = linSolve 4 g g 4.4
133 |
134 | -- Write some tests to compare it against known good output from the C program
135 | testSetBnd = TestCase (assertEqual "for setBnd 3 g" expected actual) where
136 | expected = Grid 2 (V.fromList [5,5,6,6,5,5,6,6,9,9,10,10,9,9,10,10])
137 | actual = setBnd 3 (Grid 2 (V.fromList [0..15]))
138 |
139 | testLinSolveStep = TestCase (assertEqual "linSolveStep" expected actual) where
140 | expected = Grid 2 (V.fromList [0,-16.25,-27.9375,0,16.25,16.25,27.9375,27.9375,37.6875,37.6875,70.468750,70.468750,0,-37.6875,-70.46875,0])
141 | grid = Grid 2 (V.fromList [0..15])
142 | actual = linSolve' 2 3 4 grid grid
143 |
144 | testLinSolveStep3 = TestCase (assertEqual "linsolveStep2" expected actual2) where
145 | expected = Grid 2 (V.fromList [0.0,-50.46875,-92.203125,0.0,50.46875,50.46875,92.203125,92.203125,92.953125,92.953125,141.3671875,141.3671875,0.0,-92.953125,-141.3671875,0.0])
146 | grid = Grid 2 (V.fromList [0..15])
147 | actual1 = linSolve' 2 3 4 grid grid
148 | actual2 = linSolve' 2 3 4 grid actual1
149 |
150 | testAdvect = TestCase (assertEqual "advect" expected actual) where
151 | actual = advect 3 grid (grid,grid) 9
152 | grid = Grid 2 (V.fromList [0..15])
153 | expected = Grid 2 (V.fromList [2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5])
154 |
155 | absDifference :: DVector -> DVector -> Double
156 | absDifference v1 v2 = sqrt (V.sum (V.map (\y -> y*y) (V.zipWith (-) v1 v2)))
157 |
158 | nearlyEqual :: DVector -> DVector -> Bool
159 | nearlyEqual x y = absDifference x y < 0.0001
160 |
161 | testDensStep = TestCase (assertBool "densStep" (nearlyEqual x' x && nearlyEqual x0 x0')) where
162 | (Grid 2 x',Grid 2 x0') = densStep grid grid (grid,grid) 3 4
163 | grid = Grid 2 (V.fromList [0..15])
164 | expected = Grid 2 (V.fromList [0..15])
165 | x = V.fromList [11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760,11.495760]
166 | x0 = V.fromList [11.495760,11.495760,11.636742,11.636742,11.495760,11.495760,11.636742,11.636742,11.791386,11.791386,11.932055,11.932055,11.791386,11.791386,11.932055,11.932055]
167 |
168 | testDiv = TestCase (assertEqual "div" actual expected) where
169 | grid = Grid 2 (V.fromList [0..15])
170 | expected = Fluid.div (grid,grid)
171 | actual = Grid 2 (V.fromList [-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5,-2.5])
172 |
173 | testLinSolveP = TestCase (assertBool "linSolveP" (nearlyEqual actual expected)) where
174 | grid = Grid 2 (V.fromList [0..15])
175 | d = Fluid.div (grid,grid)
176 | (Grid n actual) = linSolve 0 (setBnd 0 (emptyBoard 2)) d 1 4
177 | expected = (V.fromList [-16.180556,-16.180556,-16.597222,-16.597222,-16.180556,-16.180556,-16.597222,-16.597222,-16.597222,-16.597222,-17.013889,-17.013889,-16.597222,-16.597222,-17.013889,-17.013889])
178 |
179 | testProject = TestCase (assertBool "project" (nearlyEqual u u' && nearlyEqual v v')) where
180 | grid = Grid 2 (V.fromList [0..15])
181 | ((Grid _ u',Grid _ v'),_) = project (grid,grid)
182 | (Grid _ u) = Grid 2 (V.fromList [0.000000,5.416666,6.416666,0.000000,-5.416666,5.416666,6.416666,-6.416666,-9.416666,9.416666,10.416666,-10.416666,0.000000,9.416666,10.416666,0.000000])
183 | (Grid _ v) = Grid 2 (V.fromList [0.000000,-5.416666,-6.416666,0.000000,5.416666,5.416666,6.416666,6.416666,9.416666,9.416666,10.416666,10.416666,0.000000,-9.416666,-10.416666,0.000000])
184 |
185 | {-testVelStep = TestCase (assertBool "velStep" (nearlyEqual actual expected)) where
186 | grid = Grid 2 (V.fromList [0..15])
187 | (u,v) = velStep (grid,grid) (grid,grid)-}
188 |
189 | tests = TestList [
190 | TestLabel "setBnd" testSetBnd
191 | ,TestLabel "linSolveStep" testLinSolveStep
192 | ,TestLabel "linSolveStep3" testLinSolveStep3
193 | ,TestLabel "advect" testAdvect
194 | ,TestLabel "densStep" testDensStep
195 | ,TestLabel "project" testProject
196 | ,TestLabel "LinSolveP" testLinSolveP
197 | ,TestLabel "div" testDiv
198 | ]
--------------------------------------------------------------------------------
/fluidDynamics/MFluid.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -fno-full-laziness #-}
2 |
3 | module MFluid where
4 | -- Inspired by http://www.bestinclass.dk/index.php/2010/03/functional-fluid-dynamics-in-clojure/
5 | -- http://github.com/LauJensen/Fluid-Dynamics/raw/master/fluids.clj
6 | -- Navier Stokes (http://en.wikipedia.org/wiki/Navier–Stokes_equations)
7 |
8 | import qualified Data.Vector.Unboxed.Mutable as M
9 | import qualified Data.Vector.Generic.Mutable as GM
10 |
11 | import Criterion.Main
12 |
13 | import Control.Monad
14 |
15 | type DVector = M.IOVector Double
16 |
17 | data Grid = Grid Int DVector
18 |
19 | -- |Create an empty vector
20 | emptyGrid :: Int -> IO Grid
21 | emptyGrid sz = do
22 | d <- GM.unsafeNewWith (vectorLength sz) 0
23 | return (Grid sz d)
24 |
25 | -- |Translate from 2D to 1D co-ordinates
26 | ix :: Int -> (Int,Int) -> Int
27 | ix n (i,j) = i + (n+2) * j
28 |
29 | -- |Write a single value at the given co-ordinates
30 | writeVal :: Grid -> (Int,Int) -> Double -> IO ()
31 | writeVal (Grid sz d) p = GM.unsafeWrite d (ix sz p)
32 |
33 | -- |Write multiple values
34 | setVals :: Grid -> [((Int,Int),Double)] -> IO ()
35 | setVals g vals = forM_ vals (uncurry (writeVal g))
36 |
37 | -- |Read the value at the given point
38 | readVal :: Grid -> (Int,Int) -> IO Double
39 | readVal (Grid sz d) p = GM.unsafeRead d (ix sz p)
40 |
41 | -- |Add the sources together, writing the content out to x
42 | addSource :: Grid -> Grid -> Double -> IO ()
43 | addSource (Grid sz x) (Grid _ s) dt = forM_ [0..(vectorLength sz - 1)] $ \i -> do
44 | xa <- GM.unsafeRead x i
45 | sa <- GM.unsafeRead s i
46 | GM.unsafeWrite x i (xa + sa*dt)
47 |
48 | -- |This code is vomit inducing, but handles the edge cases..
49 | setBnd :: Int -> Grid -> IO()
50 | setBnd b g@(Grid sz _) = forM_ [1..sz]
51 | (\i ->
52 | do
53 | a1 <- readVal g (1,i)
54 | a2 <- readVal g (sz,i)
55 | a3 <- readVal g (i,1)
56 | a4 <- readVal g (i,sz)
57 | let mx | b == 1 = -1
58 | | otherwise = 1
59 | let my | b==2 = -1
60 | | otherwise = 1
61 | setVals g [((0,i) ,mx * a1)
62 | ,((sz+1,i),mx * a2)
63 | ,((i,0) ,my * a3)
64 | ,((i,sz+1),my * a4)])
65 | >> do
66 | x10 <- readVal g (1,0)
67 | x01 <- readVal g (0,1)
68 | x1n1 <- readVal g (1,sz+1)
69 | x0n <- readVal g (0,sz)
70 | xn0 <- readVal g (sz,0)
71 | xn11 <- readVal g (sz+1,1)
72 | xnn1 <- readVal g (sz,sz+1)
73 | x1nn <- readVal g (sz+1,sz)
74 | setVals g [((0,0) ,0.5 * (x10 + x01))
75 | ,((0,sz+1) ,0.5 * (x1n1 + x0n))
76 | ,((sz+1,0) ,0.5 * (xn0 + xn11))
77 | ,((sz+1,sz+1),0.5 * (xnn1 + x1nn))]
78 |
79 | -- |A simple loop over each pixel
80 | forEachPixel :: Grid -> ((Int,Int) -> IO()) -> IO()
81 | forEachPixel (Grid n _) = forM_ [(u,v) | u<-[1..n], v <- [1..n]]
82 |
83 | -- |For simplicity, just consider up,down,left,right to be the neighbours
84 | neighbours :: Grid -> (Int,Int) -> IO (Double,Double,Double,Double)
85 | neighbours g (x,y) = do
86 | up <- readVal g (x-1,y)
87 | down <- readVal g (x+1,y)
88 | left <- readVal g (x,y-1)
89 | right <- readVal g (x,y+1)
90 | return (up,down,left,right)
91 |
92 | linSolveStep :: Int -> Grid -> Grid -> Double -> Double -> IO ()
93 | linSolveStep b x x0 a c = forEachPixel x
94 | (\(i,j) ->
95 | do
96 | (up,down,left,right) <- neighbours x (i,j)
97 | x0v <- readVal x0 (i,j)
98 | writeVal x (i,j) ((x0v + a*(up + down + left + right)) / c))
99 | >> setBnd b x
100 |
101 | linSolve :: Int -> Grid -> Grid -> Double -> Double -> IO()
102 | linSolve b x x0 a c = forM_ [1..20] (\_ -> linSolveStep b x x0 a c)
103 |
104 | diffuse :: Int -> Grid -> Grid -> Double -> Double -> IO()
105 | diffuse b x@(Grid n _) x0 diff dt = linSolve b x x0 a (1 + 4*a) where
106 | a = dt * diff * (fromIntegral n * fromIntegral n)
107 |
108 | advect :: Int -> Grid -> Grid -> Grid -> Grid -> Double -> IO ()
109 | advect b d@(Grid n _) d0 u v dt = forEachPixel d
110 | (\(i,j) ->
111 | do
112 | uVal <- readVal u (i,j)
113 | vVal <- readVal v (i,j)
114 | let n5 = fromIntegral n + 0.5
115 | x = min n5 (max 0.5 (fromIntegral i - dt0 * uVal))
116 | y = min n5 (max 0.5 (fromIntegral j - dt0 * vVal))
117 | i0 = truncate x
118 | i1 = i0 + 1
119 | j0 = truncate y
120 | j1 = j0 + 1
121 | s1 = x - fromIntegral i0
122 | s0 = 1 - s1
123 | t1 = y - fromIntegral j0
124 | t0 = 1 - t1
125 | xd0 <- readVal d0 (i0,j0)
126 | xd1 <- readVal d0 (i0,j1)
127 | xd2 <- readVal d0 (i1,j0)
128 | xd3 <- readVal d0 (i1,j1)
129 | writeVal d (i,j) (s0*(t0*xd0 + t1*xd1) + s1*(t0*xd2+ t0*xd3)))
130 | >> setBnd b d
131 | where
132 | dt0 = dt * fromIntegral n
133 |
134 | project :: Grid -> Grid -> Grid -> Grid -> IO ()
135 | project u@(Grid n _) v p d = forEachPixel u
136 | (\(i,j) ->
137 | do
138 | u0 <- readVal u (i+1,j)
139 | u1 <- readVal u (i-1,j)
140 | v0 <- readVal v (i,j+1)
141 | v1 <- readVal v (i,j-1)
142 | writeVal d (i,j) (-0.5 * ((u0-u1+v0-v1) / fromIntegral n))
143 | writeVal p (i,j) 0)
144 | >> setBnd 0 d
145 | >> setBnd 0 p
146 | >> linSolve 0 p d 1 4
147 | >> forEachPixel p
148 | (\(i,j) ->
149 | do
150 | (up,down,left,right) <- neighbours p (i,j)
151 | u0 <- readVal u (i,j)
152 | v0 <- readVal v (i,j)
153 | writeVal u (i,j) (u0 - 0.5*fromIntegral n*(down - up))
154 | writeVal v (i,j) (v0 - 0.5*fromIntegral n*(right - left)))
155 | >> setBnd 1 u
156 | >> setBnd 2 v
157 |
158 | densStep :: Grid -> Grid -> Grid -> Grid -> Double -> Double -> IO ()
159 | densStep x x0 u v diff dt = do
160 | addSource x x0 dt
161 | swap x0 x
162 | diffuse 0 x x0 diff dt
163 | swap x0 x
164 | advect 0 x x0 u v dt
165 |
166 | velStep :: Grid -> Grid -> Grid -> Grid -> Double -> Double -> IO ()
167 | velStep u v u0 v0 visc dt = do
168 | addSource u u0 dt
169 | addSource v v0 dt
170 | swap u0 u
171 | diffuse 1 u u0 visc dt
172 | swap v0 v
173 | diffuse 2 v v0 visc dt
174 | project u v u0 v0
175 | swap u0 u
176 | swap v0 v
177 | advect 1 u u0 u0 v0 dt
178 | advect 2 v v0 u0 v0 dt
179 | project u v u0 v0
180 |
181 |
182 | vecToList :: DVector -> IO [Double]
183 | vecToList d = mapM (M.read d) [0..n] where
184 | n = M.length d - 1
185 |
186 | absDifference :: [Double] -> [Double] -> Double
187 | absDifference v1 v2 = sqrt (sum (map (\y -> y*y) (zipWith (-) v1 v2)))
188 |
189 | nearlyEqual :: [Double] -> [Double] -> Bool
190 | nearlyEqual x y = absDifference x y < 0.0001
191 |
192 | gridToList :: Grid -> IO [Double]
193 | gridToList (Grid _ d) = vecToList d
194 |
195 | vectorLength :: Int -> Int
196 | vectorLength sz = (sz+2)*(sz+2)
197 |
198 | listToVec :: [Double] -> IO DVector
199 | listToVec d = do
200 | let n = length d
201 | v <- GM.unsafeNewWith n 0.0
202 | mapM_ (\(x,p) -> M.write v p x) (zip d [0..])
203 | return v
204 |
205 | zeroGrid :: Grid -> IO ()
206 | zeroGrid (Grid _ ns) = M.set ns 0
207 |
208 | -- |Hideously inefficient way of swapping two vectors
209 | swap :: Grid -> Grid -> IO()
210 | swap (Grid n xs) (Grid _ ys) = forM_ [0..(vectorLength n - 1)] $ \i -> do
211 | xtmp <- GM.unsafeRead xs i
212 | ytmp <- GM.unsafeRead ys i
213 | GM.unsafeWrite xs i ytmp
214 | GM.unsafeWrite ys i xtmp
215 |
216 |
217 |
218 | testSetBnd = do
219 | putStrLn "Testing setBnd"
220 | a <- listToVec [0..15]
221 | let expected = [5,5,6,6,5,5,6,6,9,9,10,10,9,9,10,10]
222 | let example = Grid 2 a
223 | setBnd 3 example
224 | b <- vecToList a
225 | print (b == expected)
226 |
227 | testLinSolveStep = do
228 | putStrLn "Testing LinSolveStep"
229 | x <- listToVec [0..15]
230 | x0 <- listToVec [0..15]
231 | let expectedLinStep = [0,-16.25,-27.9375,0,16.25,16.25,27.9375,27.9375,37.6875,37.6875,70.468750,70.468750,0,-37.6875,-70.46875,0]
232 | linSolveStep 2 (Grid 2 x) (Grid 2 x0) 3 4
233 | c <- vecToList x
234 | print (c == expectedLinStep)
235 |
236 | testLinSolve = do
237 | putStrLn "Testing LinSolve"
238 | x <- listToVec [0..15]
239 | x0 <- listToVec [0..15]
240 | let expected = [54.999996,54.999996,56.749998,56.749998,54.999996,54.999996,56.749998,56.749998,58.250002,58.250002,60.000002,60.000002,58.250002,58.250002,60.000002,60.000002]
241 | linSolve 0 (Grid 2 x) (Grid 2 x0) 1 4
242 | c <- vecToList x
243 | print (nearlyEqual c expected)
244 |
245 | testAdvect = do
246 | putStrLn "Testing advect"
247 | let expected = [2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5,2.5]
248 | a <- listToVec [0..15]
249 | b <- listToVec [0..15]
250 | c <- listToVec [0..15]
251 | d <- listToVec [0..15]
252 | advect 3 (Grid 2 a) (Grid 2 b) (Grid 2 c) (Grid 2 d) 9
253 | result <- vecToList a
254 | print (nearlyEqual result expected)
255 |
256 | testProject = do
257 | putStrLn "Testing project"
258 | u <- listToVec [0..15]
259 | v <- listToVec [0..15]
260 | p <- listToVec [0..15]
261 | div <- listToVec [0..15]
262 | project (Grid 2 u) (Grid 2 v) (Grid 2 p) (Grid 2 div)
263 | uResult <- vecToList u
264 | vResult <- vecToList v
265 | pResult <- vecToList p
266 | divResult <- vecToList div
267 | let expectedU = [0.000000,5.416666,6.416666,0.000000,-5.416666,5.416666,6.416666,-6.416666,-9.416666,9.416666,10.416666,-10.416666,0.000000,9.416666,10.416666,0.000000]
268 | expectedV = [0.000000,-5.416666,-6.416666,0.000000,5.416666,5.416666,6.416666,6.416666,9.416666,9.416666,10.416666,10.416666,0.000000,-9.416666,-10.416666,0.000000]
269 | expectedP = [-16.180556,-16.180556,-16.597222,-16.597222,-16.180556,-16.180556,-16.597222,-16.597222,-16.597222,-16.597222,-17.013889,-17.013889,-16.597222,-16.597222,-17.013889,-17.013889]
270 | expectedDiv = [-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000,-2.500000]
271 | print (nearlyEqual uResult expectedU && nearlyEqual vResult expectedV &&
272 | nearlyEqual pResult expectedP && nearlyEqual divResult expectedDiv)
273 |
274 | testVelStep = do
275 | putStrLn "VelStep testing"
276 | let expectedX = [0.000000,0.011987,0.041284,0.000000,-0.011987,0.011987,0.041284,-0.041284,-0.016870,0.016870,0.016870,-0.016870,0.000000,0.016870,0.016870,0.000000]
277 | expectedY = [0.000000,-0.016870,-0.011987,0.000000,0.016870,0.016870,0.011987,0.011987,0.016870,0.016870,0.021753,0.021753,0.000000,-0.016870,-0.021753,0.000000]
278 | expectedU = [-0.023750,-0.023750,0.000444,0.000444,-0.023750,-0.023750,0.000444,0.000444,-0.004439,-0.004439,0.014872,0.014872,-0.004439,-0.004439,0.014872,0.014872]
279 | expectedV = [-0.043505,-0.043505,0.009765,0.009765,-0.043505,-0.043505,0.009765,0.009765,-0.000000,-0.000000,0.033740,0.033740,-0.000000,-0.000000,0.033740,0.033740]
280 | x <- listToVec [0..15]
281 | y <- listToVec [0..15]
282 | u <- listToVec [0..15]
283 | v <- listToVec [0..15]
284 | velStep (Grid 2 x) (Grid 2 y) (Grid 2 u) (Grid 2 v) 3 4
285 | xResult <- vecToList x
286 | yResult <- vecToList y
287 | uResult <- vecToList u
288 | vResult <- vecToList v
289 | print (nearlyEqual xResult expectedX && nearlyEqual yResult expectedY &&
290 | nearlyEqual uResult expectedU && nearlyEqual vResult expectedV)
291 |
292 | main = do
293 | x <- emptyGrid 80
294 | y <- emptyGrid 80
295 | u <- emptyGrid 80
296 | v <- emptyGrid 80
297 | defaultMain [
298 | bgroup "Mutable Fluids" [
299 | bench "Project" $ nfIO (project x y u v)
300 | ,bench "SetBnds" $ nfIO (setBnd 2 x)
301 | ]]
302 |
303 | tests = do
304 | testSetBnd
305 | testLinSolveStep
306 | testLinSolve
307 | testAdvect
308 | testProject
309 | testVelStep
310 | return ()
311 |
312 |
--------------------------------------------------------------------------------
/fluidDynamics/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import MFluid (densStep,velStep,readVal,writeVal,Grid,emptyGrid,zeroGrid)
4 |
5 | import Graphics.UI.GLUT as G
6 | import System.Exit (exitWith, ExitCode(ExitSuccess))
7 | import Control.Monad (unless,when,forM_)
8 | import Data.IORef (IORef, newIORef)
9 |
10 | color3f :: Color3 GLfloat -> IO ()
11 | color3f = color
12 |
13 | vertex2f :: Vertex2 GLfloat -> IO ()
14 | vertex2f = vertex :: Vertex2 GLfloat -> IO ()
15 |
16 | -- |Grid resolution
17 | n :: Int
18 | n = 80
19 |
20 | -- |Time step
21 | dt :: Double
22 | dt = 0.1
23 |
24 | -- |Diffusion rate of the density
25 | diff :: Double
26 | diff = 0.0001
27 |
28 | -- |Viscosity of the fluid
29 | visc :: Double
30 | visc = 0.002
31 |
32 | -- |Scales the mouse movement that generates a force
33 | force :: Double
34 | force = 5.0
35 |
36 | -- |Amount of density that will be deposited
37 | source :: Double
38 | source = 100.0
39 |
40 | colorVertex :: (Color3 GLfloat, Vertex2 GLfloat) -> IO ()
41 | colorVertex (c,v) = do
42 | color3f c
43 | vertex v
44 |
45 | data State = State {
46 | density :: Grid
47 | , previousDensity :: Grid
48 | , velocity :: (Grid,Grid)
49 | , previousVelocity :: (Grid,Grid)
50 | , mousePoint :: IORef (Int,Int)
51 | , oldMousePoint :: IORef (Int,Int)
52 | , leftDown :: IORef Bool
53 | , rightDown :: IORef Bool
54 | , drawVel :: IORef Bool
55 | }
56 |
57 | makeState :: IO State
58 | makeState = do
59 | densGrid <- emptyGrid n
60 | previousDensityGrid <- emptyGrid n
61 | vG1 <- emptyGrid n
62 | vG2 <- emptyGrid n
63 | vP1 <- emptyGrid n
64 | vP2 <- emptyGrid n
65 | mP <- newIORef (0,0)
66 | omP <- newIORef (0,0)
67 | left <- newIORef False
68 | right <- newIORef False
69 | mD <- newIORef False
70 | return $ State densGrid
71 | previousDensityGrid
72 | (vG1,vG2)
73 | (vP1,vP2)
74 | mP
75 | omP
76 | left
77 | right
78 | mD
79 |
80 | clearState :: State -> IO()
81 | clearState s = do
82 | zeroGrid (density s)
83 | zeroGrid (previousDensity s)
84 | let (vG1,vG2) = (velocity s)
85 | (vP1,vP2) = (previousVelocity s)
86 | zeroGrid vG1
87 | zeroGrid vG2
88 | zeroGrid vP1
89 | zeroGrid vP2
90 | mousePoint s $~ const (0,0)
91 | oldMousePoint s $~ const (0,0)
92 | leftDown s $~ const False
93 | rightDown s $~ const False
94 | drawVel s $~ const False
95 | return ()
96 |
97 | trun :: Double -> Double -> GLfloat
98 | trun h i = realToFrac ((i-0.5) * h) :: GLfloat
99 |
100 | drawVelocity :: (Grid,Grid) -> IO ()
101 | drawVelocity (u,v) = do
102 | lineWidth $= 1.0
103 | let h = 1.0 / realToFrac n
104 | let f = trun h
105 | renderPrimitive Lines $ forM_ [(x,y) | x<-[1..n], y<-[1..n] ]
106 | (\(i,j) ->
107 | do
108 | uV <- readVal u (i,j)
109 | vV <- readVal v (i,j)
110 | vertex2f (Vertex2 (f (realToFrac i)) (f (realToFrac j)))
111 | vertex2f (Vertex2 (f ((realToFrac i) + uV)) (f ((realToFrac j) + vV))))
112 |
113 | densColor :: Grid -> (Int,Int) -> IO (GLfloat,GLfloat,GLfloat,GLfloat)
114 | densColor g p@(x,y) = do
115 | d00 <- readVal g p
116 | d01 <- readVal g (x,y+1)
117 | d10 <- readVal g (x+1,y)
118 | d11 <- readVal g (x+1,y+1)
119 | return (realToFrac d00,realToFrac d01,realToFrac d10,realToFrac d11)
120 |
121 | mapToColor :: (GLfloat,GLfloat) -> GLfloat -> GLfloat -> GLfloat -> (Color3 GLfloat)
122 | mapToColor (i,j) x y z = Color3 (i*x) (j*y) (i/j * z)
123 |
124 | drawDensity :: Grid -> IO ()
125 | drawDensity g = do
126 | color3f (Color3 1 0 1)
127 | lineWidth $= 0.5
128 | let h = 1.0 / fromIntegral n
129 | let f i = (fromIntegral i - 0.5 :: GLfloat) * h
130 | renderPrimitive Quads $ forM_ [(x,y) | x<-[1..n], y<-[1..n]]
131 | (\(i,j) ->
132 | do
133 | (d00,d01,d10,d11) <- densColor g (i,j)
134 | let m = (fromIntegral i / fromIntegral n, fromIntegral j / fromIntegral n)
135 | colorVertex (mapToColor m d00 d00 d00, Vertex2 (f i) (f j))
136 | colorVertex (mapToColor m d10 d10 d10, Vertex2 (f i+h) (f j))
137 | colorVertex (mapToColor m d11 d11 d11, Vertex2 (f i+h) (f j+h))
138 | colorVertex (mapToColor m d01 d01 d01, Vertex2 (f i) (f j+h)))
139 | flush
140 |
141 | displayFunc :: State -> DisplayCallback
142 | displayFunc s = do
143 | clear [ColorBuffer]
144 | let d = density s
145 | v = velocity s
146 | dv <- G.get (drawVel s)
147 | drawDensity d
148 | when (dv) (drawVelocity v)
149 | swapBuffers
150 |
151 | pos :: Int -> (Int,Int) -> (Int,Int) -> (Int,Int)
152 | pos n (width,height) (x,y) = (truncate (dx/dw*dn), n - truncate (dy/dh*dn)) where
153 | dx = fromIntegral x :: Double
154 | dy = fromIntegral y :: Double
155 | dn = fromIntegral n :: Double
156 | dw = fromIntegral width :: Double
157 | dh = fromIntegral height :: Double
158 |
159 | updateForce :: (Int,Int) -> (Double,Double) -> (Grid,Grid) -> IO ()
160 | updateForce p (dx,dy) (u,v) = do
161 | writeVal u p (force * dx)
162 | writeVal v p (force * dy)
163 |
164 | updateDens :: (Int,Int) -> Grid -> IO ()
165 | updateDens p g = do
166 | c <- readVal g p
167 | writeVal g p (c + source)
168 |
169 | updateStateFromUI :: State -> IO()
170 | updateStateFromUI s = do
171 | (_, Size width height) <- G.get viewport
172 | (mx,my) <- G.get (mousePoint s)
173 | (omx,omy) <- G.get (oldMousePoint s)
174 | let (x,y) = pos n (fromIntegral width :: Int, fromIntegral height :: Int) (mx,my)
175 | left <- G.get (leftDown s)
176 | right <- G.get (rightDown s)
177 | let velP = previousVelocity s
178 | denP = previousDensity s
179 | when (left)
180 | (updateForce (x,y) (realToFrac (mx - omx), realToFrac (omy - my)) velP)
181 | when (right)
182 | (updateDens (x,y) denP)
183 | oldMousePoint s $~ (const (mx,my))
184 | return ()
185 |
186 | -- Update the display
187 | idleFunc :: State -> IdleCallback
188 | idleFunc s = do
189 |
190 | -- Reset the previous velocities
191 | let (u0,v0) = previousVelocity s
192 | densP = previousDensity s
193 | dens = density s
194 | (u,v) = velocity s
195 | zeroGrid u0
196 | zeroGrid v0
197 | zeroGrid densP
198 |
199 | left <- G.get (leftDown s)
200 | right <- G.get (rightDown s)
201 |
202 | -- If necessary, update the prev values
203 | when (left || right)
204 | (updateStateFromUI s)
205 |
206 | velStep u v u0 v0 visc dt
207 | densStep dens densP u v diff dt
208 |
209 | postRedisplay Nothing -- TODO should only do this if changed
210 | return ()
211 |
212 | reshapeFunc :: ReshapeCallback
213 | reshapeFunc size@(Size _ height) =
214 | unless (height == 0) $ do
215 | viewport $= (Position 0 0, size)
216 | matrixMode $= Projection
217 | loadIdentity
218 | ortho2D 0 256 0 256
219 | clearColor $= Color4 0 0 0 1
220 |
221 | setMouseData :: State -> Key -> (Int,Int) -> IO ()
222 | setMouseData s k (x,y)= do
223 | mousePoint s $~ const (x,y)
224 | oldMousePoint s $~ const (x,y)
225 | setButton s k
226 |
227 | setButton :: State -> Key -> IO ()
228 | setButton s (MouseButton LeftButton) = leftDown s $~ not
229 | setButton s (MouseButton RightButton) = rightDown s $~ not
230 | setButton _ _ = return ()
231 |
232 | keyMouseFunc :: State -> KeyboardMouseCallback
233 | keyMouseFunc _ (Char 'q') _ _ _ = exitWith ExitSuccess
234 | keyMouseFunc s (Char 'c') _ _ _ = clearState s
235 | keyMouseFunc s (Char 'v') _ _ _ = drawVel s $~ not
236 | keyMouseFunc s m _ _ (Position x y) = setMouseData s m (fromIntegral x :: Int,fromIntegral y :: Int)
237 |
238 | motionFunc :: State -> MotionCallback
239 | motionFunc s (Position x y) = do
240 | mousePoint s $~ const (fromIntegral x :: Int,fromIntegral y :: Int)
241 | return ()
242 |
243 | -- This just starts up the event loop
244 | main :: IO ()
245 | main = do
246 | _ <- getArgsAndInitialize
247 | initialDisplayMode $= [ DoubleBuffered, RGBAMode ]
248 | initialWindowSize $= Size 512 512
249 | initialWindowPosition $= Position 0 0
250 | _ <- createWindow "Barely Functional Fluid Dynamics"
251 | clearColor $= Color4 0 0 0 1
252 |
253 | state <- makeState
254 |
255 | -- Register the callback functions
256 | displayCallback $= displayFunc state
257 | idleCallback $= Just (idleFunc state)
258 | reshapeCallback $= Just reshapeFunc
259 | keyboardMouseCallback $= Just (keyMouseFunc state)
260 | motionCallback $= Just (motionFunc state)
261 |
262 | mainLoop
263 |
--------------------------------------------------------------------------------
/freebase/App.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell #-}
2 | import Yesod
3 | import Yesod.Helpers.Static
4 |
5 | import Freebase
6 | import Text.JSON
7 |
8 | data AlbumLister = AlbumLister {
9 | ajaxStatic :: Static
10 | }
11 |
12 | staticFiles "static/"
13 |
14 | mkYesod "AlbumLister" [$parseRoutes|
15 | / HomeR GET
16 | /static StaticR Static ajaxStatic
17 | /albums/#String AlbumsR GET
18 | |]
19 |
20 | instance Yesod AlbumLister where
21 | approot _ = ""
22 |
23 | --
24 | getHomeR :: Handler AlbumLister RepHtml
25 | getHomeR = hamletToRepHtml [$hamlet|
26 | %html
27 | %head
28 | %title Album Lister
29 | %link!rel="stylesheet"!href=@StaticR.albums_css@
30 | %script!src="http://code.jquery.com/jquery-1.4.2.min.js"
31 | %script!src=@StaticR.script_js@
32 | %body
33 | %h1 Album Lister
34 | %p Enter the name of a band:
35 | %input!type=text!onchange="listAlbums(this.value)"
36 | %hr
37 | #output
38 | %hr
39 | %p Written using
40 | %a!href="http://docs.yesodweb.com/Yesod" Yesod Web Framework
41 | |]
42 |
43 | getAlbumsR :: String -> Handler AlbumLister RepJson
44 | getAlbumsR band = do
45 | albumsResult <- liftIO $ getAlbumList band
46 | case albumsResult of
47 | (Ok albums) -> jsonToRepJson $ jsonMap [("name", jsonList $ map jsString albums)]
48 | (Error _) -> jsonToRepJson $ jsonMap [("error", jsString "Unknown band")]
49 |
50 | jsString :: String -> Json
51 | jsString = jsonScalar . string
52 |
53 | main :: IO ()
54 | main = do
55 | let static = fileLookupDir "static/" typeByExt
56 | basicHandler 3000 $ AlbumLister static
--------------------------------------------------------------------------------
/freebase/Freebase.hs:
--------------------------------------------------------------------------------
1 | module Freebase where
2 |
3 | import Text.JSON
4 | import Network.HTTP
5 | import Network.URI
6 |
7 | import Control.Monad
8 |
9 | import Data.Maybe (fromJust)
10 |
11 | -- Should this use fmap?
12 | lookupValue :: JSON a => Result JSValue -> String -> Result a
13 | lookupValue (Ok (JSObject o)) key = valFromObj key o
14 | lookupValue _ _ = Error "Unsupported JSON response"
15 |
16 | touch :: URI
17 | touch = fromJust $ parseURI "http://api.freebase.com/api/service/touch"
18 |
19 | status :: URI
20 | status = fromJust $ parseURI "http://api.freebase.com/api/status"
21 |
22 | version :: URI
23 | version = fromJust $ parseURI "http://api.freebase.com/api/version"
24 |
25 | simpleService :: URI -> IO (Result JSValue)
26 | simpleService s = liftM decode (simpleHTTP (mkRequest GET s) >>= getResponseBody)
27 |
28 | mqlReadUri :: String
29 | mqlReadUri = "http://api.freebase.com/api/service/mqlread"
30 |
31 | makeQuery :: JSValue -> IO (Result JSValue)
32 | makeQuery s = liftM decode (simpleHTTP (getRequest (mqlReadUri ++ "?query=" ++ urlEncode (encode s))) >>= getResponseBody)
33 |
34 | mkSimpleQuery :: [(String,JSValue)] -> JSValue
35 | mkSimpleQuery x = JSObject $ toJSObject [("query", JSObject $ toJSObject x)]
36 |
37 | getAlbumList :: String -> IO (Result [String])
38 | getAlbumList artist = do
39 | response <- makeQuery $ mkSimpleQuery [("type",showJSON "/music/artist")
40 | ,("name",showJSON artist)
41 | ,("album", JSArray [])]
42 | let albums = (lookupValue (lookupValue response "result") "album")
43 | return (fmap (map (\(JSString x) -> fromJSString x)) albums)
44 |
45 | getReleaseDate :: String -> IO (Result String)
46 | getReleaseDate film = do
47 | response <- makeQuery $ mkSimpleQuery [("type", showJSON "/film/film")
48 | ,("name", showJSON film)
49 | ,("initial_release_date", JSNull)]
50 | let releaseDate = (lookupValue (lookupValue response "result") "initial_release_date")
51 | return (fmap fromJSString releaseDate)
52 |
--------------------------------------------------------------------------------
/freebase/static/albums.css:
--------------------------------------------------------------------------------
1 | html {
2 | margin: 0;
3 | padding: 0 100px 0 100px;
4 | }
5 |
6 | body {
7 | font: 75% arial, sans-serif;
8 | background-color: #A9D0F5
9 | padding: 0 100px 0 100px;
10 | }
11 |
12 | h1 {
13 | font-size: 32pt;
14 | text-align: center;
15 | }
16 |
17 | #output {
18 | margin: 0;
19 | }
--------------------------------------------------------------------------------
/freebase/static/script.js:
--------------------------------------------------------------------------------
1 | function listAlbums (band) {
2 | jQuery.ajax({
3 | success: function(msg) {
4 | $('#output').text('');
5 | if (msg['error'] !== undefined) {
6 | $('#output').text(msg['error']);
7 | } else {
8 | $(msg['name']).each(function(idx,val) {
9 | $('#output').append('
' + val + '
');
10 | });
11 | }
12 | },
13 | url: '/albums/' + band
14 | });
15 | }
--------------------------------------------------------------------------------
/kata/Supermarket/Supermarket.hs:
--------------------------------------------------------------------------------
1 | {-
2 |
3 | Coding kata taken from http://nimblepros.com/media/36760/supermarket%20pricing%20kata.pdf
4 |
5 | -}
6 | module SuperMarket where
7 |
8 | import Test.Hspec
9 | import Test.QuickCheck
10 | import Data.Monoid
11 |
12 | data Money = Cents Integer deriving (Show,Eq)
13 |
14 | dollar :: Integer -> Money
15 | dollar x = Cents (x * 100)
16 |
17 | cents :: Integer -> Money
18 | cents = Cents
19 |
20 | data Item = Loaf
21 | | Noodles
22 | | Soup
23 |
24 | instance Monoid Money where
25 | mempty = Cents 0
26 | mappend (Cents x) (Cents y) = Cents (x + y)
27 |
28 | priceOf' :: Item -> Money
29 | priceOf' Loaf = dollar 1
30 | priceOf' Noodles = cents 50
31 | priceOf' Soup = dollar 2
32 |
33 | priceOf :: [Item] -> Money
34 | priceOf = mconcat . map priceOf'
35 |
36 | main :: IO ()
37 | main = hspec $ do
38 | describe "Supermarket pricing" $ do
39 | it "a loaf of bread is a dollar" $ do
40 | priceOf' Loaf `shouldBe` Cents 100
41 | it "a pack of noodles is 50 cents" $ do
42 | priceOf' Noodles `shouldBe` Cents 50
43 | it "a can of soup is 2 dollars" $ do
44 | priceOf' Soup `shouldBe` Cents 200
45 | it "a loaf, some noodles and soup is $3.50" $ do
46 | priceOf [Loaf,Noodles,Soup] `shouldBe` Cents 350
47 |
--------------------------------------------------------------------------------
/kepler/Kepler.chs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ForeignFunctionInterface #-}
2 | {-# LANGUAGE TypeSynonymInstances #-}
3 | module Kepler.Internal where
4 |
5 | {--
6 |
7 | # Run C2hs with the appropriate include
8 | c2hs --cppopts=-I./kepler/src/ -i./kepler/src/ Kepler.chs
9 |
10 | # After building you can start this
11 | ghci -L./kepler/src/ -lkepler
12 |
13 | #Don't forget you can do :! to execute a command from ghci
14 | :!cshs...
15 | --}
16 |
17 | #include "kepler.h"
18 | #include "fund_args.h"
19 | #include "mpc_file.h"
20 |
21 | #include "aberration.h"
22 | #include "coordinates.h"
23 | #include "julian_date.h"
24 |
25 | -- import CSH2
26 | import Foreign.C.Types
27 | import Foreign.Storable
28 | import Foreign.Ptr
29 | import Foreign.Marshal.Alloc
30 | import System.IO.Unsafe
31 | import Foreign.C
32 |
33 | {#context lib="kepler" #}
34 |
35 | {#enum solar_system_planets as Planet {}#}
36 | {#enum fund_argument as FundArgument {}#}
37 | {#enum mpc_body_types as MpcBodyType {}#}
38 |
39 | data RectangularCoordinates = RectangularCoordinates {
40 | x :: Double
41 | , y :: Double
42 | , z :: Double
43 | }
44 |
45 | data EquatorialCoordinates = EquatorialCoordinates {
46 | rightAscension :: Double
47 | , declination :: Double
48 | }
49 |
50 | data EclipticCoordinates = EclipticCoordinates {
51 | longitude :: Double -- longitude in radians
52 | , latitude :: Double -- latitude in radians
53 | }
54 |
55 | data JulianDate = JulianDate {
56 | date1 :: Double
57 | , date2 :: Double
58 | }
59 |
60 | data DegMinSec = DegMinSec {
61 | degrees :: Int
62 | , minutes :: Int
63 | , seconds :: Double
64 | }
65 |
66 | {#pointer *rectangular_coordinates as RectangularCoordinatesPtr -> RectangularCoordinates#}
67 | {#pointer *equatorial_coordinates as EquatorialCoordinatesPtr -> EquatorialCoordinates#}
68 | {#pointer *ecliptic_coordinates as EclipticCoordinatesPtr -> EclipticCoordinates#}
69 | {#pointer *julian_date as JulianDatePtr -> JulianDate#}
70 | {#pointer *deg_min_sec as DegMinSecPtr -> DegMinSec#}
71 |
72 | rectangular_coordinates_x = {#get rectangular_coordinates.x#}
73 | rectangular_coordinates_y = {#get rectangular_coordinates.y#}
74 | rectangular_coordinates_z = {#get rectangular_coordinates.z#}
75 |
76 | equatorial_coordinates_right_ascension = {#get equatorial_coordinates.right_ascension#}
77 | equatorial_coordinates_declination = {#get equatorial_coordinates.declination#}
78 |
79 | ecliptic_coordinates_longitude = {#get ecliptic_coordinates.longitude#}
80 | ecliptic_coordinates_latitude = {#get ecliptic_coordinates.latitude#}
81 |
82 | instance Storable RectangularCoordinates where
83 | sizeOf _ = {#sizeof rectangular_coordinates#}
84 |
85 | {-
86 | instance Storable RectangularCoordinates where
87 | sizeOf _ = {#sizeof *rectangular_coordinates #}
88 | alignment _ = alignment p
89 |
90 |
91 | _degrees v = {#get deg_min_sec.degrees#}
92 | _minutes v = {#get deg_min_sec.minutes#}
93 | _seconds v = {#get deg_min_sec.seconds#}
94 |
95 | -}
96 |
97 | --aberrationEarthVelocity :: JulianDate -> RectangularCoordinates
98 | --aberrationEarthVelocity = undefined
99 | {-aberrationEarthVelocity :: IO Int
100 | aberrationEarthVelocity = alloca f
101 | where
102 | f :: JulianDatePtr -> IO Int
103 | f x = return 1-}
104 |
105 |
106 |
107 |
108 |
--------------------------------------------------------------------------------
/logparse/logparse.hs:
--------------------------------------------------------------------------------
1 | -- Gather information from a log file in a functional way.
2 | import Data.Time.Clock
3 | import Data.Time.Calendar
4 | import Data.List
5 | import Data.Time.Format
6 | import Maybe
7 | import System.Locale
8 | import Char
9 |
10 | import Data.Map (Map)
11 | import qualified Data.Map as Map
12 |
13 | {--
14 |
15 | Rejected this approach after reading these two articles
16 |
17 | * http://www.haskell.org/haskellwiki/OOP_vs_type_classes
18 | * http://www.ninebynine.org/Software/Learning-Haskell-Notes.html
19 |
20 | It's probably the wrong way to go
21 |
22 | class Report2 r where
23 | printReport :: r -> String
24 |
25 | class (Eq l, Show l) => LogProcessor l where
26 | processLine2 :: String -> Maybe l
27 | combineUnit :: (Report2 r) => l -> r -> r
28 |
29 | processFile2 :: LogProcessor(a) => FilePath -> a -> IO([a])
30 | processFile2 s l = do
31 | a <- readFile s
32 | return (Maybe.mapMaybe processLine2 (lines a))
33 | --}
34 |
35 |
36 | timeFormat :: String
37 | timeFormat = "%F %T"
38 |
39 | type Package = String
40 |
41 | data Upgrade = Upgrade { packageName :: Package
42 | , updateTime :: UTCTime }
43 |
44 | instance Show Upgrade where
45 | show a = show (updateTime a) ++
46 | ":" ++ show (packageName a) ++ "\n"
47 |
48 | getTime :: String -> UTCTime
49 | getTime = fromJust . parseTime defaultTimeLocale timeFormat
50 |
51 | getPackageName :: String -> String
52 | getPackageName = takeWhile (not . Char.isSpace)
53 |
54 | parseLine :: String -> Maybe Upgrade
55 | parseLine s
56 | | isInfixOf " upgrade " s = Just
57 | (Upgrade
58 | (takeWhile (not . Char.isSpace) (drop 28 s))
59 | (getTime (take 20 s)))
60 | | otherwise = Nothing
61 |
62 |
63 | processFile :: FilePath -> (String -> Maybe t) -> IO([t])
64 | processFile path f = do
65 | a <- readFile path
66 | return (Maybe.mapMaybe f (lines a))
67 |
68 | type Report = Map Day [Package]
69 |
70 | combine :: [Upgrade] -> String
71 | combine = show . foldl addToReport Map.empty
72 |
73 | addToReport :: Report -> Upgrade -> Report
74 | addToReport r p = Map.insert day packages r where
75 | day = utctDay (updateTime p)
76 | initVal = Map.findWithDefault [] day r
77 | packages = packageName p:initVal
78 |
79 | reportFile :: FilePath -> (String -> Maybe t) -> ([t] -> String) -> IO()
80 | reportFile path func comb = do
81 | a <- processFile path func
82 | print (comb a)
83 | return ()
84 |
85 |
86 |
87 |
88 | {--
89 | exampleFile :: String
90 | exampleFile = "/home/jfoster/package_logs.txt"
91 |
92 | timeFormat :: String
93 | timeFormat = "%F %T"
94 |
95 | type Package = String
96 |
97 | data Upgrade = Upgrade { packageName :: Package
98 | , updateTime :: UTCTime }
99 |
100 | instance Show Upgrade where
101 | show a = show (updateTime a) ++
102 | ":" ++ show (packageName a) ++ "\n"
103 |
104 | getTime :: String -> UTCTime
105 | getTime = fromJust . parseTime defaultTimeLocale timeFormat
106 |
107 | getPackageName :: String -> String
108 | getPackageName = takeWhile (not . Char.isSpace)
109 |
110 | -- Poor mans parsing.
111 | parseLine :: String -> Maybe Upgrade
112 | parseLine s
113 | | isInfixOf " upgrade " s = Just
114 | (Upgrade
115 | (takeWhile (not . Char.isSpace) (drop 28 s))
116 | (getTime (take 20 s)))
117 | | otherwise = Nothing
118 |
119 | processFile :: FilePath -> IO([Upgrade])
120 | processFile s = do
121 | a <- readFile s
122 | return (Maybe.mapMaybe parseLine (lines a))
123 |
124 | type Report = Map Day [Package]
125 |
126 | combine :: [Upgrade] -> Report
127 | combine = foldl addToReport Map.empty
128 |
129 | addToReport :: Report -> Upgrade -> Report
130 | addToReport r p = Map.insert day packages r where
131 | day = utctDay (updateTime p)
132 | initVal = Map.findWithDefault [] day r
133 | packages = packageName p:initVal
134 |
135 | reportFile :: FilePath -> IO()
136 | reportFile f = do
137 | a <- processFile f
138 | print (combine a)
139 | return ()
140 | --}
--------------------------------------------------------------------------------
/misc/TypeClassopedia.hs:
--------------------------------------------------------------------------------
1 | import Data.Maybe
2 |
3 | -- fmap :: (a -> b) -> f a -> f b
4 | onList = fmap (+ 1) [1,2,3]
5 | onJust = fmap (+ 1) (Just 4)
6 | onNothing = fmap (+ 1) Nothing
7 |
8 | data MyTree a = Leaf a
9 | | Node a (MyTree a) (MyTree a)
10 | deriving (Show,Eq)
11 |
12 | instance Functor MyTree where
13 | fmap f (Leaf a) = Leaf (f a)
14 | fmap f (Node a b c) = (Node (f a) (fmap f b) (fmap f c))
15 |
16 | exampleTree :: MyTree Int
17 | exampleTree = Node 5 (Node 3 (Leaf 2) (Leaf 1)) (Node 6 (Leaf 7) (Leaf 8))
18 |
19 |
--------------------------------------------------------------------------------
/monte-carlo/WorldCup.hs:
--------------------------------------------------------------------------------
1 | module WorldCup where
2 |
3 | import Data.Maybe (fromJust)
4 | import Data.List (sortBy)
5 | import Data.List.Split (splitEvery)
6 | import qualified Data.Map as Map
7 |
8 | import System.Random
9 |
10 | type Ranking = Double
11 |
12 | type League = Map.Map Team Int
13 |
14 | data GameResult = Win | Lose | Draw
15 | deriving (Show,Eq)
16 |
17 | data Team = RSA | MEX | URA | FRA |
18 | ARG | NGA | KOR | GRE |
19 | ENG | USA | ALG | SVN |
20 | GER | AUS | SRB | GHA |
21 | NED | DEN | JPN | CMR |
22 | ITA | PAR | NZL | SVK |
23 | BRA | PRK | CIV | POR |
24 | ESP | SUI | HON | CHI
25 | deriving (Show,Eq,Ord)
26 |
27 | data GroupName = A | B | C | D | E | F | G | H
28 | deriving (Show,Eq,Enum)
29 |
30 | data Group = Group GroupName (Team,Team,Team,Team) deriving (Show)
31 |
32 | data WorldCup = WorldCup [Group] deriving (Show)
33 |
34 | data KnockoutStage = KnockoutStage [Team] deriving (Show)
35 |
36 | class Model a where
37 | play :: a -> Team -> Team -> GameResult
38 | winner :: a -> Team -> Team -> Team
39 |
40 | data RankingModel = RankingModel {
41 | ratings :: [(Team,Ranking)]
42 | } deriving (Show)
43 |
44 | instance Model RankingModel where
45 | play = play'
46 | winner = winner'
47 |
48 | play' :: RankingModel -> Team -> Team -> GameResult
49 | play' (RankingModel m) x y = case result of
50 | GT -> Win
51 | LT -> Lose
52 | EQ -> Draw
53 | where
54 | r1 = fromJust $ lookup x m
55 | r2 = fromJust $ lookup y m
56 | result = compare (truncate r1 `div` 25) (truncate r2 `div` 25)
57 |
58 | winner' :: RankingModel -> Team -> Team -> Team
59 | winner' m x y = case result of
60 | Win -> x
61 | Lose -> y
62 | Draw -> x
63 | where
64 | result = play' m x y
65 |
66 | -- |Simulate the world cup
67 | rankings28April :: [(Team,Ranking)]
68 | rankings28April =
69 | [
70 | (RSA,369), (MEX,936), (URA,902), (FRA,1044),
71 | (ARG,1084), (NGA,883), (KOR,619), (GRE,968),
72 | (ENG,1068), (USA,950), (ALG,821), (SVN,860),
73 | (GER,1107), (AUS,883), (SRB,944), (GHA,802),
74 | (NED,1221), (DEN,767), (JPN,674), (CMR,887),
75 | (ITA,1184), (PAR,882), (NZL,413), (SVK,742),
76 | (BRA,1611), (PRK,292), (CIV,846), (POR,1249),
77 | (ESP,1565), (SUI,854), (HON,727), (CHI,948)
78 | ]
79 |
80 | makeGroup :: GroupName -> (Team,Team,Team,Team) -> Group
81 | makeGroup = Group
82 |
83 | groupA :: Group
84 | groupA = makeGroup A (RSA, MEX, URA, FRA)
85 |
86 | groupB :: Group
87 | groupB = makeGroup B (ARG, NGA, KOR, GRE)
88 |
89 | groupC :: Group
90 | groupC = makeGroup C (ENG, USA, ALG, SVN)
91 |
92 | groupD :: Group
93 | groupD = makeGroup D (GER, AUS, SRB, GHA)
94 |
95 | groupE :: Group
96 | groupE = makeGroup E (NED, DEN, JPN, CMR)
97 |
98 | groupF :: Group
99 | groupF = makeGroup F (ITA, PAR, NZL, SVK)
100 |
101 | groupG :: Group
102 | groupG = makeGroup G (BRA, PRK, CIV, POR)
103 |
104 | groupH :: Group
105 | groupH = makeGroup H (ESP, SUI, HON, CHI)
106 |
107 | wcGroups :: [Group]
108 | wcGroups = [groupA,groupB,groupC,groupD,groupE,groupF,groupG,groupH]
109 |
110 | worldCup :: WorldCup
111 | worldCup = WorldCup wcGroups
112 |
113 | rules :: [(GroupName,Int)]
114 | rules = [(A,1),(F,1),(B,1),(E,1),(C,1),(H,1),(D,1),(G,1),
115 | (B,2),(E,2),(A,2),(F,2),(D,2),(G,2),(C,2),(H,2)]
116 |
117 | scoreGame :: League -> ((Team,Team),GameResult) -> League
118 | scoreGame r ((x,_),Win) = Map.insertWith (+) x 3 r
119 | scoreGame r ((_,y),Lose) = Map.insertWith (+) y 3 r
120 | scoreGame r ((x,y),Draw) = Map.insertWith (+) y 1 (Map.insertWith (+) x 1 r)
121 |
122 | scoreGames :: League -> [((Team,Team),GameResult)] -> League
123 | scoreGames = foldl scoreGame
124 |
125 | fixtures :: (Team,Team,Team,Team) -> [(Team,Team)]
126 | fixtures (a,b,c,d) = [(a,b),(a,c),(a,d),(b,c),(b,d),(c,d)]
127 |
128 | initialLeague :: (Team,Team,Team,Team) -> League
129 | initialLeague (a,b,c,d) = Map.fromList [(a,0),(b,0),(c,0),(d,0)]
130 |
131 | playGroup :: Model a => a -> Group -> League
132 | playGroup model (Group _ t) = scoreGames (initialLeague t) (zip matches results)
133 | where
134 | matches = fixtures t
135 | results = map (uncurry (play model)) matches :: [GameResult]
136 |
137 | lookupPosition :: [(GroupName,League)] -> (GroupName,Int) -> Team
138 | lookupPosition s (n,x) | x == 1 = fst $ head sortedList
139 | | x == 2 = fst $ head $ tail sortedList
140 | | otherwise = error "Invalid rules for looking up groups"
141 | where
142 | l = Map.toList $ fromJust (lookup n s)
143 | sortedList = sortBy (\(_,a) (_,b) -> compare b a) l
144 |
145 | advanceToKnockOut :: Model a => WorldCup -> a -> KnockoutStage
146 | advanceToKnockOut (WorldCup groups) model = KnockoutStage teams where
147 | groupWinners = zip [A .. H] (map (playGroup model) groups) :: [(GroupName,League)]
148 | teams = map (lookupPosition groupWinners) rules
149 |
150 | nextRound :: Model a => a -> KnockoutStage -> KnockoutStage
151 | nextRound _ (KnockoutStage (x:[])) = KnockoutStage [x]
152 | nextRound model (KnockoutStage teams) = KnockoutStage results where
153 | len = length teams `div` 2
154 | matchUps = uncurry zip $ splitAt len teams
155 | results = map (uncurry (winner model)) matchUps
156 |
157 | simulate :: Model a => WorldCup -> a -> Team
158 | simulate wc model = head x where
159 | knockOut = advanceToKnockOut wc model
160 | rounds = iterate (nextRound model) knockOut
161 | KnockoutStage x = rounds !! 4
162 |
163 | simulations :: Model a => WorldCup -> [a] -> League
164 | simulations wc = foldl (simulateOne wc) Map.empty
165 |
166 | simulateOne :: Model a => WorldCup -> League -> a -> League
167 | simulateOne wc league model = Map.insertWith (+) w 1 league
168 | where
169 | w = simulate wc model
170 |
171 | createRatings :: [Double] -> [(Team,Ranking)]
172 | createRatings p = map (\(x,(w,r)) -> (w,x*r)) (zip p rankings28April) where
173 |
174 | createRankings :: [RankingModel]
175 | createRankings = map (RankingModel . createRatings) weightings
176 | where
177 | weightings = splitEvery 32 randomDoubles
178 |
179 | seed :: Int
180 | seed = 32158972315
181 |
182 | generator :: StdGen
183 | generator = mkStdGen seed
184 |
185 | randomDoubles :: [Double]
186 | randomDoubles = map (\x -> (x*0.6) + 0.70) (randoms generator)
187 |
188 | main :: IO ()
189 | main = do
190 | let models = (take 100000 createRankings)
191 | results = simulations worldCup models
192 | print results
--------------------------------------------------------------------------------
/newton/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Orbit as O
4 |
5 | import Graphics.UI.GLUT as G
6 | import System.Exit (exitWith, ExitCode(ExitSuccess))
7 | import Control.Monad (unless,when,forM_)
8 | import Data.IORef (IORef, newIORef)
9 | import Data.List.Split (chunk)
10 |
11 | import System.Random
12 |
13 | delta :: Int
14 | delta = 25
15 |
16 | objectCount :: Int
17 | objectCount = 60
18 |
19 | data State = State {
20 | world :: IORef [O.Object]
21 | }
22 |
23 | center :: Vec O.Position
24 | center = Vec 0 0
25 |
26 | type ObjectSeed = (Double,Double,Double,Double)
27 |
28 | makeState :: IO State
29 | makeState = do
30 | gen <- newStdGen
31 | let ns = map (\(a:b:c:d:[]) -> (a,b,c,d)) $ chunk 4 (randoms gen :: [Double])
32 | p <- newIORef (createWorld (take objectCount ns))
33 | return $ State p
34 |
35 | -- Create the world using the given source of randomness
36 | createWorld :: [ObjectSeed] -> [O.Object]
37 | createWorld rnds = sun : map (\(s,n) -> randomObject s sun n) (zip rnds [1..])
38 | where
39 | sun = O.Object center 30 (Vec 0 0) (Vec 0 0)
40 |
41 |
42 | randomPosition :: Double -> Double -> Vec O.Position -> Vec O.Position
43 | randomPosition x y sunPos = add sunPos (Vec (r * cos theta) (r * sin theta))
44 | where
45 | r = x * 150 + 80
46 | theta = y * 2 * pi
47 |
48 | randomVelocity :: Double -> Vec O.Position -> O.Object -> Vec O.Velocity
49 | randomVelocity r p sun = convert (O.scale direction (r*0.3 + 0.3)) O.Velocity where
50 | direction = rotate90 (unit $ sub p (O.position sun))
51 |
52 | randomObject :: (Double,Double,Double,Double) -> O.Object -> Int -> O.Object
53 | randomObject (mass,vel,a,b) sun n = o
54 | where
55 | p = randomPosition a b (O.position sun)
56 | o = O.Object p (mass * 0.2) (randomVelocity vel p sun) zero
57 |
58 |
59 | -- TODO color
60 | drawObject :: O.Object -> IO ()
61 | drawObject o = preservingMatrix $ do
62 | translate (Vector3 (realToFrac x) (realToFrac y) 0.0 :: Vector3 GLfloat)
63 | renderObject Solid $ Sphere' radius 100 100
64 | where
65 | (Vec x y) = O.position o
66 | radius = realToFrac $ sizeByMass (mass o)
67 |
68 | colorByMass :: Double -> Color4 Double
69 | colorByMass m = Color4 r g b 1 where
70 | b = min 255 (20.0 * m) / 255.0
71 | r = min 100 (255.0 - b) / 255.0
72 | g = 128.0
73 |
74 | sizeByMass :: Double -> Double
75 | sizeByMass = (+) 3.0
76 |
77 | displayFunc :: State -> DisplayCallback
78 | displayFunc state = do
79 | clear [ColorBuffer,DepthBuffer]
80 | materialAmbient Front $= Color4 1 0 0 1
81 | materialDiffuse Front $= Color4 0 1 0 1
82 | materialSpecular Front $= Color4 1 1 1 1
83 | materialShininess Front $= 1000
84 | s <- G.get (world state)
85 | mapM_ drawObject s
86 | swapBuffers
87 |
88 | initGraphics :: IO ()
89 | initGraphics = do
90 | depthFunc $= Just Less
91 | clearDepth $= 100
92 | matrixMode $= Modelview 0
93 | loadIdentity
94 | lighting $= Enabled
95 | light (Light 0) $= Enabled
96 | G.position (Light 0) $= Vertex4 0 0 (-100) 1
97 | ambient (Light 0) $= Color4 1 1 1 1
98 | diffuse (Light 0) $= Color4 1 1 1 1
99 | specular (Light 0) $= Color4 1 1 1 1
100 | matrixMode $= Projection
101 | loadIdentity
102 | ortho (-500) 500 (-500) 500 200 (-200)
103 |
104 | timerCallback :: State -> TimerCallback
105 | timerCallback state = do
106 | world state $~ updateAll
107 | postRedisplay Nothing
108 | addTimerCallback delta (timerCallback state)
109 |
110 | main :: IO ()
111 | main = do
112 | _ <- getArgsAndInitialize
113 | initialDisplayMode $= [DoubleBuffered, RGBAMode]
114 | initialWindowSize $= Size 512 512
115 | initialWindowPosition $= G.Position 0 0
116 | _ <- createWindow "Orbit in Haskell"
117 | _ <- initGraphics
118 |
119 | state <- makeState
120 |
121 | displayCallback $= displayFunc state
122 | addTimerCallback delta (timerCallback state)
123 |
124 | mainLoop
--------------------------------------------------------------------------------
/newton/Orbit.hs:
--------------------------------------------------------------------------------
1 | module Orbit where
2 |
3 | import Data.List (delete,(\\),nub,nubBy)
4 |
5 | -- Phantom types so as to not mix up quantities
6 | data Position = Position deriving Eq
7 | data Velocity = Velocity deriving Eq
8 | data Force = Force deriving Eq
9 |
10 | data Vec a = Vec Double Double deriving (Show,Eq)
11 |
12 | data Object = Object {
13 | position :: Vec Position
14 | , mass :: Double
15 | , velocity :: Vec Velocity
16 | , force :: Vec Force
17 | } deriving (Show,Eq)
18 |
19 | convert :: Vec a -> b -> Vec b
20 | convert (Vec x y) _ = Vec x y :: Vec b
21 |
22 | add :: Vec a -> Vec a -> Vec a
23 | add (Vec u v) (Vec x y) = Vec (u+x) (v+y)
24 |
25 | sub :: Vec a -> Vec a -> Vec a
26 | sub (Vec u v) (Vec x y) = Vec (u-x) (v-y)
27 |
28 | average :: Vec a -> Vec a -> Vec a
29 | average (Vec u v) (Vec x y) = Vec ((u+x)/2) ((v+y)/2)
30 |
31 | distance :: Vec a -> Vec a -> Double
32 | distance (Vec u v) (Vec x y) = sqrt (a + b) where
33 | sq z = z*z
34 | a = sq (u - x)
35 | b = sq (v - y)
36 |
37 | scale :: Vec a -> Double -> Vec a
38 | scale (Vec x y) s = Vec (x*s) (y*s)
39 |
40 | magnitude :: Vec a -> Double
41 | magnitude (Vec x y) = sqrt (x*x + y*y)
42 |
43 | unit :: Vec a -> Vec a
44 | unit v | mv == 0 = v
45 | | otherwise = scale v (1 / mv)
46 | where
47 | mv = magnitude v
48 |
49 | zero :: Vec a
50 | zero = Vec 0 0
51 |
52 | rotate90 :: Vec a -> Vec a
53 | rotate90 (Vec x y) = Vec (- y) x
54 |
55 | gravity :: Double -> Double -> Double -> Double
56 | gravity m1 m2 r | r == 0 = 0
57 | | otherwise = (m1 * m2) / (r * r)
58 |
59 | forceBetween :: Object -> Object -> Vec Force
60 | forceBetween (Object p1 m1 _ _)
61 | (Object p2 m2 _ _) = scale uv g where
62 | uv = convert (unit (sub p2 p1)) Force
63 | g = gravity m1 m2 (distance p1 p2)
64 |
65 | accumulateForces :: Object -> [Object] -> Object
66 | accumulateForces o os = o {
67 | force = foldl forceFunc zero (delete o os)
68 | }
69 | where
70 | forceFunc f target = add f (forceBetween o target)
71 |
72 | calculateForcesOnAll :: [Object] -> [Object]
73 | calculateForcesOnAll os = map (`accumulateForces` os) os
74 |
75 | accelerate :: Object -> Object
76 | accelerate o = o {
77 | force = zero
78 | , velocity = av
79 | }
80 | where
81 | f = force o
82 | m = mass o
83 | v = velocity o
84 | av = add v (convert (scale f (1 / m)) Velocity)
85 |
86 | accelerateAll :: [Object] -> [Object]
87 | accelerateAll = map accelerate
88 |
89 | reposition :: Object -> Object
90 | reposition o = o {
91 | position = add p (convert v Position)
92 | }
93 | where
94 | p = position o
95 | v = velocity o
96 |
97 | repositionAll :: [Object] -> [Object]
98 | repositionAll = map reposition
99 |
100 | collide :: Object -> Object -> Bool
101 | collide x y = distance (position x) (position y) <= 3
102 |
103 | merge :: Object -> Object -> Object
104 | merge x y = Object {
105 | position = add p1 d
106 | , mass = mergedMass
107 | , velocity = scale (add mv1 mv2) (1 / mergedMass)
108 | , force = add (force x) (force y)
109 | }
110 | where
111 | mx = mass x
112 | my = mass y
113 | mergedMass = mx + my
114 | s = mx / mergedMass
115 | p1 = position x
116 | p2 = position y
117 | uv = unit $ sub p2 p1
118 | d = scale uv s
119 | mv1 = scale (velocity x) mx
120 | mv2 = scale (velocity y) my
121 |
122 | collideAll :: [Object] -> [Object]
123 | collideAll os = merged ++ (os \\ collidedObjects)
124 | where
125 | pairs = nubBy (\(a,b) (c,d) -> a==d && b==c) [(x,y) | x<-os,y<-os, x/=y] :: [(Object,Object)]
126 | collidedPairs = filter (uncurry collide) pairs
127 | collidedObjects = nub $ concatMap (\(x,y) -> [x,y]) collidedPairs
128 | merged = map (uncurry merge) collidedPairs
129 |
130 | updateAll :: [Object] -> [Object]
131 | updateAll = collideAll . calculateForcesOnAll . accelerateAll . repositionAll
--------------------------------------------------------------------------------
/newton/OrbitTest.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, FlexibleInstances #-}
2 |
3 | module OrbitTest where
4 |
5 | import Orbit
6 | import Test.QuickCheck
7 |
8 |
9 |
10 | instance Arbitrary Object where
11 | arbitrary = do
12 | px <- arbitrary
13 | py <- arbitrary
14 | m <- arbitrary
15 | vx <- arbitrary
16 | vy <- arbitrary
17 | return Object {
18 | position = Vec px py
19 | , mass = abs m + 0.1 -- zero mass not supported
20 | , velocity = Vec vx vy
21 | , force = zero
22 | }
23 |
24 | energy :: [Object] -> Double
25 | energy os = sum (map ke os) where
26 | ke o = 0.5 * (mass o) * v * v
27 | where
28 | v = (magnitude $ velocity o)
29 |
30 | prop_EnergyConserved :: [Object] -> Bool
31 | prop_EnergyConserved os = abs ((energy os) - (energy $ update os)) < 0.01 where
32 | update =calculateForcesOnAll . accelerateAll . repositionAll
33 |
34 | prop_unitLength :: Double -> Double -> Bool
35 | prop_unitLength 0 0 = True
36 | prop_unitLength x y = abs ((magnitude $ unit v) - 1.0) < 0.0001 where
37 | v = Vec x y :: Vec Force
38 |
39 |
--------------------------------------------------------------------------------
/project-simulator/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright (c) 2014, Jeff Foster
2 |
3 | All rights reserved.
4 |
5 | Redistribution and use in source and binary forms, with or without
6 | modification, are permitted provided that the following conditions are met:
7 |
8 | * Redistributions of source code must retain the above copyright
9 | notice, this list of conditions and the following disclaimer.
10 |
11 | * Redistributions in binary form must reproduce the above
12 | copyright notice, this list of conditions and the following
13 | disclaimer in the documentation and/or other materials provided
14 | with the distribution.
15 |
16 | * Neither the name of Jeff Foster nor the names of other
17 | contributors may be used to endorse or promote products derived
18 | from this software without specific prior written permission.
19 |
20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 |
--------------------------------------------------------------------------------
/project-simulator/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/project-simulator/project-simulator.cabal:
--------------------------------------------------------------------------------
1 | -- Initial project-simulator.cabal generated by cabal init. For further
2 | -- documentation, see http://haskell.org/cabal/users-guide/
3 |
4 | -- The name of the package.
5 | name: project-simulator
6 |
7 | -- The package version. See the Haskell package versioning policy (PVP)
8 | -- for standards guiding when and how versions should be incremented.
9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy
10 | -- PVP summary: +-+------- breaking API changes
11 | -- | | +----- non-breaking API additions
12 | -- | | | +--- code changes with no API change
13 | version: 0.1.0.0
14 |
15 | -- A short (one-line) description of the package.
16 | synopsis: Does some really basic simulation of projects
17 |
18 | -- A longer description of the package.
19 | -- description:
20 |
21 | -- URL for the project homepage or repository.
22 | homepage: http://www.fatvat.co.uk/
23 |
24 | -- The license under which the package is released.
25 | license: BSD3
26 |
27 | -- The file containing the license text.
28 | license-file: LICENSE
29 |
30 | -- The package author(s).
31 | author: Jeff Foster
32 |
33 | -- An email address to which users can send suggestions, bug reports, and
34 | -- patches.
35 | maintainer: jeff.foster@acm.org
36 |
37 | -- A copyright notice.
38 | -- copyright:
39 |
40 | -- category:
41 |
42 | build-type: Simple
43 |
44 | -- Extra files to be distributed with the package, such as examples or a
45 | -- README.
46 | -- extra-source-files:
47 |
48 | -- Constraint on the version of Cabal needed to build this package.
49 | cabal-version: >=1.10
50 |
51 |
52 | executable project-simulator
53 | -- .hs or .lhs file containing the Main module.
54 | main-is: Main.hs
55 |
56 | -- Modules included in this executable, other than Main.
57 | -- other-modules:
58 |
59 | -- LANGUAGE extensions used by modules in this package.
60 | -- other-extensions:
61 |
62 | -- Other library packages from which modules are imported.
63 | build-depends: base >=4.7 && <4.8,
64 | time >= 1.4,
65 | containers >= 0.5.5,
66 | random-fu >= 0.2.6
67 |
68 | -- Directories containing source files.
69 | hs-source-dirs: src
70 |
71 | -- Base language which the package is written in.
72 | default-language: Haskell2010
73 |
--------------------------------------------------------------------------------
/project-simulator/src/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Projects
4 |
5 | main :: IO ()
6 | main = putStrLn "Hello world"
7 |
--------------------------------------------------------------------------------
/project-simulator/src/Projects.hs:
--------------------------------------------------------------------------------
1 | module Projects where
2 |
3 | -- TODO smart constructor to hide the use of double internally
4 | -- and only allow construction with a nominal diff time
5 |
6 | data Project = Project
7 | {
8 | name :: String
9 | , bestCaseEstimate :: Double
10 | , mostLikelyEstimate :: Double
11 | , worstCaseEstimate :: Double
12 | } deriving (Show)
13 |
14 | weightedAverage :: Project -> Double
15 | weightedAverage p = (a + 4 * m + b) / 6
16 | where
17 | a = bestCaseEstimate p
18 | m = mostLikelyEstimate p
19 | b = worstCaseEstimate p
20 |
21 | standardDeviation :: Project -> Double
22 | standardDeviation p = (b - a) / 6
23 | where
24 | a = bestCaseEstimate p
25 | b = worstCaseEstimate p
26 |
27 |
--------------------------------------------------------------------------------
/project-simulator/src/Simulate.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE MultiParamTypeClasses #-}
2 |
3 | module Simulate where
4 |
5 | import Projects
6 |
7 | import Data.Random
8 | import Data.Random.Distribution.Triangular
9 | import Control.Monad
10 |
11 | data Report = Report [ProjectCompletion] deriving (Show)
12 |
13 | data ProjectCompletion = ProjectCompletion
14 | {
15 | project :: Project
16 | , completionTimes :: [Double]
17 | } deriving (Show)
18 |
19 | sampleSize :: Int
20 | sampleSize = 100000
21 |
22 | simulate :: [Project] -> Report
23 | simulate = undefined
24 |
25 | estimate :: MonadRandom m => Project -> m [Double]
26 | estimate p = replicateM sampleSize (sample $ pdf p)
27 |
28 | pdf :: Project -> RVar Double
29 | pdf p = floatingTriangular
30 | (bestCaseEstimate p)
31 | (mostLikelyEstimate p)
32 | (worstCaseEstimate p)
33 |
34 | normalPair :: RVar (Double,Double)
35 | normalPair = do
36 | u <- stdUniform
37 | t <- stdUniform
38 | let r = sqrt (-2 * log u)
39 | theta = (2 * pi) * t
40 |
41 | x = r * cos theta
42 | y = r * sin theta
43 | return (x,y)
44 |
45 |
--------------------------------------------------------------------------------
/rwh/ch03.hs:
--------------------------------------------------------------------------------
1 | import Data.List
2 |
3 | -- 1. Write a function that computes the number of elements in a list.
4 | -- To test it, ensure it gives the same answers as the standard
5 | -- length function
6 |
7 | -- 2. Add a type signature
8 | myLength :: [a] -> Integer
9 | myLength = foldl (\ acc _ -> succ acc) 0
10 |
11 | -- 3. Write a function that computes the mean of a list (i.e. the sum of all
12 | -- elements in the list divided by its length.
13 | mean :: (Fractional a) => [a] -> a
14 | mean [] = 0
15 | mean x = foldr (+) 0 x / fromIntegral (length x)
16 |
17 | -- 4. Turn a list into a plaindrome
18 | palindrome :: [a] -> [a]
19 | palindrome x = x ++ reverse x
20 |
21 | -- 5. Write a function that determines whether its nput list is a palindrome
22 | isPalindrome :: (Eq a) => [a] -> Bool
23 | isPalindrome x = reverse x == x
24 |
25 | -- 6. Create a function that sorts a list of lists based on the length of
26 | -- each sublist.
27 | sortBySubListLength :: [[a]] -> [[a]]
28 | sortBySubListLength = sortBy (\x y -> compare (length x) (length y))
29 |
30 | -- 7. Define a function that joins a list of lists together using a separator value
31 | myIntersperse _ [] = []
32 | myIntersperse _ [x] = [x]
33 | myIntersperse s (x:xs) = x : s : myIntersperse s xs
34 |
35 |
36 | -- 8. Define a function to calculate the height of the tree
37 | data Tree a = Node a (Tree a) (Tree a)
38 | | Empty
39 | deriving (Show)
40 |
41 | height :: (Tree a) -> Integer
42 | height Empty = 0
43 | height (Node _ t1 t2) = 1 + max (height t1) (height t2)
44 |
45 | -- 9. Consider three two-dimensional points, a,b, and c. If we look at the angle formed
46 | -- by the line segments from a to b it is either left, right or straight.
47 |
48 | -- Left is an existing function...
49 | data Direction = Straight
50 | | LeftTurn
51 | | RightTurn
52 | deriving (Show,Eq)
53 |
54 | -- 10. Write a function that calculates the turn made by three two-dimensional points
55 | -- and returns a direction
56 | data Point = Point Double Double
57 | deriving (Show,Eq)
58 |
59 | -- From Wikipedia
60 | -- ... determining whether three points constitute a "left turn" or a "right turn" does
61 | -- not require computing the actual angle between the two line segments, and can actually
62 | -- be achieved with simple arithmetic only. For three points (x1,y1), (x2,y2) and (x3,y3),
63 | -- simply compute the direction of the cross product of the two vectors defined by points
64 | -- (x1,y1), (x2,y2) and (x1,y1), (x3,y3), characterized by the sign of the expression
65 | -- (x2 − x1)(y3 − y1) − (y2 − y1)(x3 − x1)
66 | turn :: Point -> Point -> Point -> Direction
67 | turn a b c = makeDirection (cross a b c) where
68 | makeDirection x | x == 0 = Straight
69 | | x < 0 = LeftTurn
70 | | x > 0 = RightTurn
71 |
72 | cross :: Point -> Point -> Point -> Double
73 | cross (Point x1 y1) (Point x2 y2) (Point x3 y3) = (x2-x1)*(y3-y1)-(x3-x1)*(y2-y1)
74 |
75 | dist :: Point -> Point -> Double
76 | dist (Point x1 y1) (Point x2 y2) = sqrt((x1-x2)^2 + (y1-y2)^2)
77 |
78 | compareCross :: Point -> Point -> Point -> Ordering
79 | compareCross pvt a b = if angle == EQ then distance else angle where
80 | angle = compare (cross pvt a b) 0
81 | distance = compare (dist pvt a) (dist pvt b)
82 |
83 | getTurns :: [Point] -> [(Point,Direction)]
84 | getTurns (x:y:z:ps) = (y,turn x y z) : getTurns (y:z:ps)
85 | getTurns _ = []
86 |
87 | -- grahamScan :: [Point] -> [Direction]
88 | grahamScan :: [Point] -> [Point]
89 | grahamScan points = map fst (filter (\(x,d) -> d /= RightTurn) (getTurns sortedPoints)) where
90 | p = nub points
91 | pvt = lowestY p
92 | sortedPoints = pvt : (sortBy (compareCross pvt) (delete pvt p) ++ [pvt,pvt]
93 |
94 | -- We have two ways of sorting, by minimum y co-ordinate (or X if there is a draw)
95 | compareYPoint :: Point -> Point -> Ordering
96 | compareYPoint (Point x1 y1) (Point x2 y2)
97 | | y1 == y2 = compare x1 x2
98 | | y1 <= y2 = LT
99 | | otherwise = GT
100 |
101 | -- Or by cotangent to point with the min co-ordinate
102 | compareAngle :: Point -> Point -> Point -> Ordering
103 | compareAngle (Point px py) p1 p2 = compare (angle p2) (angle p1) where
104 | angle (Point x1 y1) = y1-py / x1-px
105 |
106 |
107 | lowestY :: [Point] -> Point
108 | lowestY = minimumBy compareYPoint
109 |
110 | pointsFromTupleList :: [(Double,Double)] -> [Point]
111 | pointsFromTupleList = map (uncurry Point)
112 |
113 | examplePoints :: [Point]
114 | examplePoints = pointsFromTupleList [(0,0),(2,0),(2,2),(0,2),(1,1)]
115 |
--------------------------------------------------------------------------------
/scrabble/Scrabble.hs:
--------------------------------------------------------------------------------
1 | module Scrabble where
2 |
3 | import Dictionary
4 |
5 | import Data.Map (Map)
6 | import qualified Data.Map as Map
7 | import Data.Maybe
8 | import Data.List.Split
9 |
10 | -- There's 100 tiles in a standard distribution
11 | data Tile = Tile Char Int deriving (Eq,Show)
12 |
13 | data Score = Normal
14 | | DoubleLetter
15 | | DoubleWord
16 | | TripleLetter
17 | | TripleWord
18 | deriving (Show)
19 |
20 | data Square = Square Score (Maybe Tile)
21 | deriving (Show)
22 |
23 | type Board = Map (Int,Int) Square
24 |
25 | data Player = Player1 Int
26 | | Player2 Int
27 |
28 | data Game = Game {
29 | board :: Board
30 | , turn :: Player
31 | , remainingTiles :: [Tile]
32 | , player1 :: Player
33 | , player2 :: Player
34 | }
35 |
36 | tileToChar :: Tile -> Char
37 | tileToChar (Tile x _) = x
38 |
39 | squareToChar :: Square -> Char
40 | squareToChar (Square _ x) | Nothing == x = '/'
41 | | otherwise = tileToChar (fromJust x)
42 |
43 | squareToScoreChar :: Square -> Char
44 | squareToScoreChar (Square x _) = scoreToChar x
45 |
46 | scoreToChar :: Score -> Char
47 | scoreToChar Normal = '-'
48 | scoreToChar DoubleLetter = 'd'
49 | scoreToChar TripleLetter = 't'
50 | scoreToChar DoubleWord = 'D'
51 | scoreToChar TripleWord = 'T'
52 |
53 | instance Show Game where
54 | show = renderWithTiles
55 |
56 | renderGame :: Game -> (Square -> Char) -> String
57 | renderGame (Game b t tiles p1 p2) f = concat $ map (++ "\n") $ splitEvery 15 sqs
58 | where
59 | sqs = map f [ b Map.! (x,y) | x <- [0..14], y <- [0..14]]
60 |
61 | renderWithTiles :: Game -> String
62 | renderWithTiles g = renderGame g squareToChar
63 |
64 | renderWithScore :: Game -> String
65 | renderWithScore g = renderGame g squareToScoreChar
66 |
67 | -- All the valid tiles
68 | tileSet = [('A', Tile 'A' 1),('B', Tile 'B' 3),('C', Tile 'C' 3)
69 | ,('D', Tile 'D' 2),('E', Tile 'E' 1),('F', Tile 'F' 4)
70 | ,('G', Tile 'G' 2),('H', Tile 'H' 4),('I', Tile 'I' 1)
71 | ,('J', Tile 'J' 8),('K', Tile 'K' 5),('L', Tile 'L' 1)
72 | ,('M', Tile 'M' 3),('N', Tile 'N' 1),('O', Tile 'O' 1)
73 | ,('P', Tile 'P' 3),('Q', Tile 'Q' 1),('R', Tile 'R' 1)
74 | ,('S', Tile 'S' 1),('T', Tile 'T' 1),('U', Tile 'U' 1)
75 | ,('V', Tile 'V' 4),('W', Tile 'W' 4),('X', Tile 'X' 8)
76 | ,('Y', Tile 'Y' 4),('Z', Tile 'Z' 10),(' ', Tile ' ' 0)]
77 |
78 | -- Distribution of tiles
79 | tileDistribution = [(9,'A'),(2,'B'),(2,'C'),(4,'D'),(12,'E')
80 | ,(2,'F'),(3,'G'),(2,'H'),(9,'I'),(1,'J')
81 | ,(1,'K'),(4,'L'),(2,'M'),(6,'N'),(8,'O')
82 | ,(2,'P'),(1,'Q'),(6,'R'),(4,'S'),(6,'T')
83 | ,(4,'U'),(2,'V'),(2,'W'),(1,'X'),(2,'Y')
84 | ,(1,'Z'),(2,' ')]
85 |
86 | -- Location of triple word scores
87 | tripleW :: [(Int,Int)]
88 | tripleW = [(0,0),(7,0),(14,14),(0,7),
89 | (14,0),(7,14),(0,14),(14,7)]
90 |
91 | -- Location of double letter scores
92 | doubleL :: [(Int,Int)]
93 | doubleL = [(3,0),(11,0),(3,14),(11,14) -- sides
94 | ,(0,3),(0,11),(14,3),(14,11)
95 | ,(6,2),(8,2),(7,3)
96 | ,(6,12),(8,12),(7,11)
97 | ,(2,6),(2,8),(3,7)
98 | ,(12,6),(12,8),(11,7)
99 | ,(6,6),(8,8),(8,6),(6,8)
100 | ,(7,7)]
101 |
102 | -- Location of triple letter scores
103 | tripleL :: [(Int,Int)]
104 | tripleL = [(5,1),(9,1)
105 | ,(1,5),(1,9)
106 | ,(13,5),(13,9)
107 | ,(5,13),(9,13)
108 | ,(5,5),(9,5)
109 | ,(5,9),(9,9)]
110 |
111 | -- Location of double word scores
112 | doubleW :: [(Int,Int)]
113 | doubleW = [(1,1),(2,2),(3,3),(4,4)
114 | ,(13,13),(12,12),(11,11),(10,10)
115 | ,(13,1),(12,2),(11,3),(10,4)
116 | ,(1,13),(2,12),(3,11),(4,10)]
117 |
118 | initialGame :: Game
119 | initialGame = Game initialBoard turn tiles player1 player2
120 | where
121 | player1 = Player1 0
122 | player2 = Player2 0
123 | turn = player1
124 |
125 | initialBoard :: Board
126 | initialBoard = Map.fromList [((x,y),lookupSq (x,y)) | x <- [0..14], y <- [0..14]]
127 |
128 | lookupSq :: (Int,Int) -> Square
129 | lookupSq (x,y) | (x,y) `elem` doubleW = Square DoubleWord Nothing
130 | | (x,y) `elem` tripleW = Square TripleWord Nothing
131 | | (x,y) `elem` doubleL = Square DoubleLetter Nothing
132 | | (x,y) `elem` tripleL = Square TripleLetter Nothing
133 | | otherwise = Square Normal Nothing
134 |
135 | tiles :: [Tile]
136 | tiles = concatMap (\(n,t) -> replicate n (fromJust $ lookup t tileSet)) tileDistribution
137 |
138 | {-
139 |
140 | T--d---T---d--T
141 | -D---t-------D-
142 | --D----d-d--D--
143 | d--D----d--D--d
144 | ----D-----D----
145 | -t---t---tt--t-
146 | ------d-d------
147 | T-d---------d-T
148 | ---d--d-d--d---
149 | --d--t---t--d--
150 | -t--D-----D--t-
151 | d--D----d--D--d
152 | --D----d-d--D--
153 | -D---t----t--D-
154 | T--d---T---d--T
155 |
156 |
157 | -}
--------------------------------------------------------------------------------
/spoj/Fctrl.hs:
--------------------------------------------------------------------------------
1 | -- Success
2 | import Control.Monad (forM_)
3 |
4 | readInteger :: String -> Integer
5 | readInteger = read
6 |
7 | readInt :: String -> Int
8 | readInt = read
9 |
10 | -- http://www.purplemath.com/modules/factzero.htm
11 | factSub :: Integer -> Integer
12 | factSub n = sum $ takeWhile (>= 1) $ (drop 1 $ iterate (`div` 5) n)
13 |
14 | main :: IO ()
15 | main = do
16 | nStr <- readLn :: IO Integer
17 | forM_ [1..nStr]
18 | (\t ->
19 | do
20 | nS <- getLine
21 | let n = readInteger nS
22 | ans = factSub n
23 | print ans
24 | )
25 |
--------------------------------------------------------------------------------
/stablemarriage/Examples.hs:
--------------------------------------------------------------------------------
1 | module Examples where
2 |
3 | import StableMarriage
4 |
5 | wolfram1 :: [(Int,[Int])]
6 | wolfram1 = [(1,[7,3,8,9,6,4,2,1,5])
7 | ,(2,[5,4,8,3,1,2,6,7,9])
8 | ,(3,[4,8,3,9,7,5,6,1,2])
9 | ,(4,[9,7,4,2,5,8,3,1,6])
10 | ,(5,[2,6,4,9,8,7,5,1,3])
11 | ,(6,[2,7,8,6,5,3,4,1,9])
12 | ,(7,[1,6,2,3,8,5,4,9,7])
13 | ,(8,[5,6,9,1,2,8,4,3,7])
14 | ,(9,[6,1,4,7,5,8,3,9,2])]
15 |
16 | wolfram2 :: [(Int,[Int])]
17 | wolfram2 = [(1,[3,1,5,2,8,7,6,9,4])
18 | ,(2,[9,4,8,1,7,6,3,2,5])
19 | ,(3,[3,1,8,9,5,4,2,6,7])
20 | ,(4,[8,7,5,3,2,6,4,9,1])
21 | ,(5,[6,9,2,5,1,4,7,3,8])
22 | ,(6,[2,4,5,1,6,8,3,9,7])
23 | ,(7,[9,3,8,2,7,5,4,6,1])
24 | ,(8,[6,3,2,1,8,4,5,9,7])
25 | ,(9,[8,2,6,4,9,1,3,7,5])]
26 |
27 | set1 :: [(Char,[Char])]
28 | set1 = [('A',"abcd"),
29 | ('B',"bacd"),
30 | ('C',"adcb"),
31 | ('D',"dcab")]
32 |
33 | set2 :: [(Char,[Char])]
34 | set2 = [('a',"ABCD"),
35 | ('b',"DBCA"),
36 | ('c',"ABCD"),
37 | ('d',"CDAB")]
38 |
39 | setA :: [(String,[String])]
40 | setA = [("abe",["abi", "eve", "cath", "ivy", "jan", "dee", "fay", "bea", "hope", "gay"]),
41 | ("bob",[ "cath", "hope", "abi", "dee", "eve", "fay", "bea", "jan", "ivy", "gay"]),
42 | ("col",[ "hope", "eve", "abi", "dee", "bea", "fay", "ivy", "gay", "cath", "jan"]),
43 | ("dan",[ "ivy", "fay", "dee", "gay", "hope", "eve", "jan", "bea", "cath", "abi"]),
44 | ("ed",[ "jan", "dee", "bea", "cath", "fay", "eve", "abi", "ivy", "hope", "gay"]),
45 | ("fred",[ "bea", "abi", "dee", "gay", "eve", "ivy", "cath", "jan", "hope", "fay"]),
46 | ("gav",[ "gay", "eve", "ivy", "bea", "cath", "abi", "dee", "hope", "jan", "fay"]),
47 | ("hal",[ "abi", "eve", "hope", "fay", "ivy", "cath", "jan", "bea", "gay", "dee"]),
48 | ("ian",[ "hope", "cath", "dee", "gay", "bea", "abi", "fay", "ivy", "jan", "eve"]),
49 | ("jon",[ "abi", "fay", "jan", "gay", "eve", "bea", "dee", "cath", "ivy", "hope"])]
50 |
51 | setB :: [(String,[String])]
52 | setB = [("abi",[ "bob", "fred", "jon", "gav", "ian", "abe", "dan", "ed", "col", "hal"]),
53 | ("bea",[ "bob", "abe", "col", "fred", "gav", "dan", "ian", "ed", "jon", "hal"]),
54 | ("cath",[ "fred", "bob", "ed", "gav", "hal", "col", "ian", "abe", "dan", "jon"]),
55 | ("dee",[ "fred", "jon", "col", "abe", "ian", "hal", "gav", "dan", "bob", "ed"]),
56 | ("eve",[ "jon", "hal", "fred", "dan", "abe", "gav", "col", "ed", "ian", "bob"]),
57 | ("fay",[ "bob", "abe", "ed", "ian", "jon", "dan", "fred", "gav", "col", "hal"]),
58 | ("gay",[ "jon", "gav", "hal", "fred", "bob", "abe", "col", "ed", "dan", "ian"]),
59 | ("hope",[ "gav", "jon", "bob", "abe", "ian", "dan", "hal", "ed", "col", "fred"]),
60 | ("ivy",[ "ian", "col", "hal", "gav", "fred", "bob", "abe", "ed", "jon", "dan"]),
61 | ("jan",[ "ed", "hal", "gav", "abe", "bob", "jon", "col", "ian", "fred", "dan"])]
62 |
--------------------------------------------------------------------------------
/stablemarriage/StableMarriage.hs:
--------------------------------------------------------------------------------
1 | module StableMarriage where
2 |
3 | import Data.List
4 | import Data.Maybe
5 |
6 | stableMatch :: (Eq m, Eq w) => [(m,[w])] -> [(w,[m])] -> [(m,w)]
7 | stableMatch ms ws = stableMatch' []
8 | where
9 | stableMatch' ps = case unmarried ms ps of
10 | Just unmarriedMan -> stableMatch' (findMatch unmarriedMan ws ps)
11 | Nothing -> ps
12 |
13 | -- Outcome - m is always married to someone
14 | findMatch :: (Eq m,Eq w) => (m,[w]) -> [(w,[m])] -> [(m,w)] -> [(m,w)]
15 | findMatch (m,w:rest) ws ps = case isEngaged w ps of
16 |
17 | -- w is already engaged to m' - is there a better match?
18 | Just m' -> if prefers (getPrefs ws w) m m'
19 | then engage (breakup m' ps) m w
20 | else findMatch (m,rest) ws ps
21 |
22 | -- can match with first choice
23 | Nothing -> engage ps m w
24 |
25 | getPrefs :: Eq w => [(w,m)] -> w -> m
26 | getPrefs ws w = fromJust $ lookup w ws
27 |
28 | isEngaged :: Eq w => w -> [(m,w)] -> Maybe m
29 | isEngaged w ps = fmap fst (find (\x -> snd x == w) ps)
30 |
31 | engage :: [(m,w)] -> m -> w -> [(m,w)]
32 | engage xs a b = (a,b) : xs
33 |
34 | breakup :: Eq m => m -> [(m,w)] -> [(m,w)]
35 | breakup m = filter (\x -> fst x /= m)
36 |
37 | -- Returns the first man in in ms not in ps
38 | unmarried :: Eq m => [(m,[w])] -> [(m,w)] -> Maybe (m,[w])
39 | unmarried ms ps = find (\(m,_) -> m `notElem` engagedMen) ms
40 | where
41 | engagedMen = map fst ps
42 |
43 | -- Returns true if w prefers first over second
44 | prefers :: Eq m => [m] -> m -> m -> Bool
45 | prefers ms m1 m2 = go ms
46 | where
47 | go [] = error "no match"
48 | go (x:xs)
49 | | x == m1 = True
50 | | x == m2 = False
51 | | otherwise = go xs
52 |
53 |
--------------------------------------------------------------------------------
/traffic/Traffic.hs:
--------------------------------------------------------------------------------
1 | module Traffic where
2 |
3 | import Data.Map (Map)
4 | import qualified Data.Map as M
5 |
6 | import Data.List (sortBy)
7 | import Data.Maybe (fromJust)
8 | import Data.Ord (comparing)
9 |
10 | import System.Random
11 | import Text.Printf
12 |
13 | import Test.QuickCheck
14 | import Debug.Trace
15 |
16 | type Position = (Double,Double)
17 | type Speed = Double
18 | type Route = Map (Location,Location) Speed
19 |
20 | data Location = Location {
21 | position :: Position
22 | , name :: String
23 | } deriving (Eq,Ord,Show)
24 |
25 | data Car = Car {
26 | distanceToDestination :: Double
27 | , speed :: Speed
28 | , route :: (Location,Location)
29 | } deriving (Eq,Show)
30 |
31 | data Environment = Environment {
32 | locations :: [Location]
33 | , routes :: Route
34 | , cars :: [Car]
35 | , noise :: [Double] -- infinite list of randomness
36 | } deriving (Show)
37 |
38 | createLocations :: [Location]
39 | createLocations = map (\z -> Location (x z,y z) "X") [0,(pi/15) .. (2*pi)]
40 | where
41 | x theta = 100 * cos theta + 128
42 | y theta = 100 * sin theta + 128
43 |
44 | makeRoutes :: [Location] -> Route
45 | makeRoutes locations = M.fromList (zip (zip locations (cycle $ tail locations)) (repeat 5))
46 |
47 | makeCars :: Route -> [Car]
48 | makeCars r = map (\((s,f),_) -> Car 1.0 1.0 (s,f)) (M.toList r)
49 |
50 | createRoutes :: [((Location,Location), Speed)] -> Route
51 | createRoutes r = M.fromList $ concatMap (\((x,y),s) -> [((x,y),s), ((y,x),s)]) r
52 |
53 | createEnvironment = Environment {
54 | locations = createLocations
55 | , routes = makeRoutes createLocations
56 | , cars = makeCars (makeRoutes createLocations)
57 | , noise = randoms (mkStdGen 100)
58 | }
59 |
60 | {- Actual Logic of simulation -}
61 | update :: Environment -> Environment
62 | update env = env' { cars = updateCars env (cars env) }
63 | where
64 | env' = env { noise = drop (length (cars env)) (noise env) }
65 |
66 | carsOnRoute :: Car -> [Car] -> [Car]
67 | carsOnRoute car = filter (\c -> route c == route car && c /= car)
68 |
69 | updateCars :: Environment -> [Car] -> [Car]
70 | updateCars env cars = map (\(c,n) -> updateCar env n c) (zip cars (noise env))
71 |
72 | updateCar :: Environment -> Double -> Car -> Car
73 | updateCar env d car = updateCarSpeed env d (updateCarPosition env d car)
74 |
75 | updateCarSpeed :: Environment -> Double -> Car -> Car
76 | updateCarSpeed env d car | null nearestCars = car
77 | | distanceBetween < 3 = car { speed = min maxSpeed (speed car * (1 + d*0.01)) }
78 | | distanceBetween > 3 = car { speed = max 0.1 (speed car * (1 - d*0.01)) }
79 | | otherwise = car
80 | where
81 | maxSpeed = min maximumAhead (fromJust $ M.lookup (route car) (routes env))
82 | nearestCars = filter (\x -> distanceToDestination x > (distanceToDestination car))
83 | $ sortBy (comparing distanceToDestination) (carsOnRoute car (cars env))
84 | carAhead = head nearestCars
85 | maximumAhead = ((speed carAhead + distanceToDestination carAhead) - distanceToDestination car)
86 | distanceBetween = distanceToDestination (head nearestCars) - distanceToDestination car
87 |
88 | updateCarPosition :: Environment -> Double -> Car -> Car
89 | updateCarPosition env choice car | distanceToGo <= 0 = updateLocation env choice car
90 | | otherwise = car { distanceToDestination = distanceToGo }
91 | where
92 | distanceToGo = distanceToDestination car - speed car
93 |
94 | updateLocation :: Environment -> Double -> Car -> Car
95 | updateLocation env choice car = car {
96 | distanceToDestination = distanceToGo
97 | , route = (finish,newDestination)
98 | }
99 | where
100 | (start,finish) = route car
101 | newDestination = chooseNewDestination env choice finish
102 | distanceToGo = distanceBetween (position finish) (position newDestination)
103 |
104 | chooseNewDestination :: Environment -> Double -> Location -> Location
105 | chooseNewDestination env choice s = snd $ fst (choices !! truncate (choice * realToFrac (length choices)))
106 | where
107 | choices = filter (\((x,_),_) -> x == s) (M.toList (routes env))
108 |
109 |
110 | carPosition :: Car -> Position
111 | carPosition (Car d _ (start,finish)) = (x1+p*(x2-x1), y1+p*(y2-y1))
112 | where
113 | s@(x1,y1) = position start
114 | e@(x2,y2) = position finish
115 | p = 1 - (d / distanceBetween s e)
116 |
117 | distanceBetween :: Position -> Position -> Double
118 | distanceBetween (x1,y1) (x2,y2) = sqrt ((x1-x2)^2 + (y1-y2)^2)
119 |
120 | {- Functions for manipulating the environment -}
121 | changeSpeedLimit :: (Speed -> Speed) -> Environment -> Environment
122 | changeSpeedLimit d e = e { routes = updatedRoutes }
123 | where
124 | updatedRoutes = M.map d (routes e)
125 |
126 | addCar :: Environment -> Environment
127 | addCar e = e { cars = cars' }
128 | where
129 | cars' = Car 1.0 1.0 (s,f) : (cars e)
130 | ((s,f),_) = head (M.toList (routes e))
131 |
132 | removeCar :: Environment -> Environment
133 | removeCar e = e { cars = cars' }
134 | where
135 | cars' = drop 1 (cars e)
136 |
137 | stats :: Environment -> String
138 | stats e = "Average speed: " ++ (printf "%.3f" avgSpeed)
139 | where
140 | c = cars e
141 | avgSpeed = sum (map speed c) / realToFrac (length c)
142 |
143 | {- Testing code. -}
144 | getCarLocation :: Double -> Position -> Position -> Position
145 | getCarLocation d s e = carPosition (Car d 0 (Location s "Start",Location e "End"))
146 |
147 | -- |The distance we are at is calculated correctly
148 | prop_distanceCorrect :: NonNegative Double -> Position -> Position -> Bool
149 | prop_distanceCorrect (NonNegative d) s e | s == e = True -- prefer different positions!
150 | | abs d > dis = True
151 | | otherwise = abs (db - d) < 0.0001
152 | where
153 | dis = distanceBetween s e
154 | pos = getCarLocation d s e
155 | db = distanceBetween pos e
156 |
--------------------------------------------------------------------------------
/traffic/TrafficVis.hs:
--------------------------------------------------------------------------------
1 | module TrafficVis where
2 |
3 | -- To compile
4 | -- ghc -lglut --make -main-is TrafficVis -fforce-recomp TrafficVis.hs
5 |
6 | import Traffic
7 |
8 | import Graphics.UI.GLUT as G
9 | import System.Exit (exitWith, ExitCode(ExitSuccess))
10 | import Control.Monad (unless, when, forM_,liftM,liftM2)
11 | import Data.IORef (IORef, newIORef)
12 |
13 | import qualified Data.Map as M
14 |
15 | data State = State {
16 | env :: IORef Environment
17 | , run :: IORef Bool
18 | }
19 |
20 | -- |Timeout in ms for callback
21 | tick :: Int
22 | tick = 25
23 |
24 | -- |Pixels per world cell
25 | scale :: Int
26 | scale = 5
27 |
28 | makeState :: IO State
29 | makeState = liftM2 State (newIORef createEnvironment) (newIORef False)
30 |
31 | displayFunc :: State -> DisplayCallback
32 | displayFunc s = do
33 | clear [ColorBuffer]
34 | environment <- G.get (env s)
35 | _ <- drawCars (cars environment)
36 | _ <- drawRoutes (routes environment)
37 | _ <- drawLocations (locations environment)
38 | _ <- drawInfo environment
39 | flush
40 | swapBuffers
41 |
42 | color3f :: Color3 GLfloat -> IO ()
43 | color3f = color
44 |
45 | vertex2f :: Vertex2 GLfloat -> IO ()
46 | vertex2f = vertex :: Vertex2 GLfloat -> IO ()
47 |
48 | vertex2d :: Double -> Double -> Vertex2 GLfloat
49 | vertex2d x y = Vertex2 (realToFrac x) (realToFrac y)
50 |
51 | drawCars :: [Car] -> IO ()
52 | drawCars = mapM_ drawCar
53 |
54 | drawCar :: Car -> IO ()
55 | drawCar car = do
56 | let (x,y) = carPosition car
57 | color3f (Color3 1 0 0)
58 | pointSize $= realToFrac 20
59 | renderPrimitive Triangles $ do
60 | vertex2f (vertex2d x y)
61 | vertex2f (vertex2d (x - 5) y)
62 | vertex2f (vertex2d x (y + 5))
63 |
64 | drawRoutes :: Route -> IO ()
65 | drawRoutes route = mapM_ (\((l1,l2),speed) -> drawRoute l1 l2 speed) (M.toList route)
66 |
67 | drawRoute :: Location -> Location -> Double -> IO ()
68 | drawRoute (Location (x1,y1) _) (Location (x2,y2) _) m = do
69 | lineWidth $= realToFrac 0.5
70 | color3f (Color3 0 1 0)
71 | renderPrimitive Lines $ do
72 | vertex2f (vertex2d x1 y1)
73 | vertex2f (vertex2d x2 y2)
74 |
75 | drawLocations :: [Location] -> IO ()
76 | drawLocations = mapM_ drawLocation
77 |
78 | drawLocation :: Location -> IO ()
79 | drawLocation (Location (x,y) _) = do
80 | color3f (Color3 0 0 1)
81 | pointSize $= realToFrac 3
82 | renderPrimitive Points (vertex2f (vertex2d x y))
83 |
84 | drawInfo :: Environment -> IO ()
85 | drawInfo e = do
86 | rasterPos (vertex2d 5 240)
87 | renderString Fixed8By13 (stats e)
88 |
89 | -- remember to postRedisplay Nothing if changed
90 | -- no logic should go here
91 | timerFunc :: State -> IO ()
92 | timerFunc s = do
93 | shouldRun <- G.get (run s)
94 | when shouldRun (env s $~ update)
95 | postRedisplay Nothing
96 | addTimerCallback tick (timerFunc s)
97 |
98 | reshapeFunc :: ReshapeCallback
99 | reshapeFunc size@(Size _ height) =
100 | unless (height == 0) $ do
101 | viewport $= (Position 0 0, size)
102 | matrixMode $= Projection
103 | loadIdentity
104 | ortho2D 0 256 0 256
105 | clearColor $= Color4 0 0 0 1
106 |
107 | keyboardMouseHandler :: State -> KeyboardMouseCallback
108 | keyboardMouseHandler state (Char '+') Down _ _ = env state $~ (changeSpeedLimit (* 1.01))
109 | keyboardMouseHandler state (Char '-') Down _ _ = env state $~ (changeSpeedLimit (* 0.99))
110 | keyboardMouseHandler state (Char 'a') Down _ _ = env state $~ addCar
111 | keyboardMouseHandler state (Char 'd') Down _ _ = env state $~ removeCar
112 | keyboardMouseHandler state (Char ' ') Down _ _ = run state $~ not
113 | keyboardMouseHandler _ _ _ _ _ = return ()
114 |
115 | main :: IO ()
116 | main = do
117 | _ <- getArgsAndInitialize
118 | initialDisplayMode $= [ DoubleBuffered, RGBAMode ]
119 | initialWindowSize $= Size 512 512
120 | initialWindowPosition $= Position 0 0
121 | _ <- createWindow "Stop the traffic!"
122 | clearColor $= Color4 0 0 0 1
123 |
124 | state <- makeState
125 |
126 | displayCallback $= displayFunc state
127 | reshapeCallback $= Just reshapeFunc
128 | keyboardMouseCallback $= Just (keyboardMouseHandler state)
129 | addTimerCallback tick (timerFunc state)
130 |
131 | mainLoop
--------------------------------------------------------------------------------
/websockets/GameOfLife.hs:
--------------------------------------------------------------------------------
1 | import Char
2 | import Web
3 | import System.IO
4 |
5 | import Data.Array
6 |
7 | data Cell = Off
8 | | On
9 | | Dying
10 | deriving (Eq,Show)
11 |
12 | cellToChar :: Cell -> Char
13 | cellToChar Off = '0'
14 | cellToChar On = '1'
15 | cellToChar Dying = '2'
16 |
17 | charToCell :: Char -> Cell
18 | charToCell '0' = Off
19 | charToCell '1' = On
20 | charToCell '2' = Dying
21 | charToCell _ = error "Undefined character received"
22 |
23 | type GameGrid = Array (Int,Int) Cell
24 |
25 | type Neighbours = [Cell]
26 |
27 | data Game = Game GameGrid Int deriving Show
28 |
29 | createGame :: Int -> [Cell] -> Game
30 | createGame x c = Game (listArray ((0,0),(x-1,x-1)) c) x
31 |
32 | gridToString :: Game -> String
33 | gridToString (Game g _) = map cellToChar (elems g)
34 |
35 | neighbours :: Game -> (Int,Int) -> Neighbours
36 | neighbours (Game c s) (x,y) = [c ! ((x+dx) `mod` s, (y+dy) `mod` s)
37 | | dx <- [-1,0,1], dy <- [-1,0,1], dx /= dy]
38 |
39 | rules :: Cell -> Neighbours -> Cell
40 | rules On _ = Dying
41 | rules Off cells | length (filter (/= Off) cells) == 2 = On
42 | | otherwise = Off
43 | rules Dying _ = Off
44 |
45 | step :: Game -> [Cell]
46 | step g@(Game c s) = [ rules (c ! p) (neighbours g p) | p <- coords] where
47 | coords = [(x,y) | x <- [0..(s-1)], y <- [0..(s-1)]]
48 |
49 | processMessage :: String -> String
50 | processMessage s = map cellToChar newGrid where
51 | [cellSizeStr,original] = lines s
52 | cells = map charToCell original
53 | cellSize = read cellSizeStr :: Int
54 | newGrid = step (createGame cellSize cells)
55 |
56 | listenLoop :: Handle -> IO ()
57 | listenLoop h = do
58 | msg <- readFrame h
59 | sendFrame h (processMessage msg)
60 | listenLoop h
61 |
62 | main :: IO ()
63 | main = serverListen 9876 listenLoop
64 |
--------------------------------------------------------------------------------
/websockets/Web.hs:
--------------------------------------------------------------------------------
1 | module Web (serverListen, sendFrame, readFrame) where
2 |
3 | import Network
4 | import System.IO
5 | import Char
6 | import Control.Concurrent
7 | import Control.Monad
8 |
9 | -- restarting an apache server (apache2ctl restart)
10 | -- magic configuration file /etc/apache2/sites-available/default
11 |
12 | -- http://www.haskell.org/haskellwiki/Roll_your_own_IRC_bot
13 |
14 | -- tcpdump -i lo (run as sudo)
15 |
16 | -- Should really parse this out to headers!
17 | serverHandshake :: String
18 | serverHandshake =
19 | "HTTP/1.1 101 Web Socket Protocol Handshake\r\n\
20 | \Upgrade: WebSocket\r\n\
21 | \Connection: Upgrade\r\n\
22 | \WebSocket-Origin: http://localhost\r\n\
23 | \WebSocket-Location: ws://localhost:9876/\r\n\
24 | \WebSocket-Protocol: sample\r\n\r\n"
25 |
26 | acceptLoop :: Socket -> (Handle -> IO ()) -> IO a
27 | acceptLoop socket f = forever $ do
28 | (h,_,_) <- accept socket
29 | hPutStr h serverHandshake
30 | hSetBuffering h NoBuffering
31 | forkIO (f h)
32 |
33 | serverListen :: PortNumber -> (Handle -> IO()) -> IO()
34 | serverListen port f = withSocketsDo $ do
35 | socket <- listenOn (PortNumber port)
36 | acceptLoop socket f
37 | sClose socket
38 | return ()
39 |
40 | sendFrame :: Handle -> String -> IO ()
41 | sendFrame h s = do
42 | hPutChar h (chr 0)
43 | hPutStr h s
44 | hPutChar h (chr 255)
45 |
46 | readFrame :: Handle -> IO String
47 | readFrame h = readUntil h ""
48 | where
49 | readUntil hl str = do
50 | new <- hGetChar hl
51 | if new == chr 0
52 | then readUntil hl ""
53 | else if new == chr 255
54 | then return str
55 | else readUntil hl (str ++ [new])
56 |
57 |
58 |
59 |
--------------------------------------------------------------------------------
/websockets/base64.js:
--------------------------------------------------------------------------------
1 | /* Copyright (C) 1999 Masanao Izumo
2 | * Version: 1.0
3 | * LastModified: Dec 25 1999
4 | * This library is free. You can redistribute it and/or modify it.
5 | */
6 |
7 | /*
8 | * Interfaces:
9 | * b64 = base64encode(data);
10 | * data = base64decode(b64);
11 | */
12 |
13 | (function() {
14 |
15 | var base64EncodeChars = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
16 | var base64DecodeChars = new Array(
17 | -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
18 | -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1,
19 | -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, -1, 62, -1, -1, -1, 63,
20 | 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, -1, -1, -1, -1, -1, -1,
21 | -1, 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14,
22 | 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, -1, -1, -1, -1, -1,
23 | -1, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40,
24 | 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, -1, -1, -1, -1, -1);
25 |
26 | function base64encode(str) {
27 | var out, i, len;
28 | var c1, c2, c3;
29 |
30 | len = str.length;
31 | i = 0;
32 | out = "";
33 | while(i < len) {
34 | c1 = str.charCodeAt(i++) & 0xff;
35 | if(i == len)
36 | {
37 | out += base64EncodeChars.charAt(c1 >> 2);
38 | out += base64EncodeChars.charAt((c1 & 0x3) << 4);
39 | out += "==";
40 | break;
41 | }
42 | c2 = str.charCodeAt(i++);
43 | if(i == len)
44 | {
45 | out += base64EncodeChars.charAt(c1 >> 2);
46 | out += base64EncodeChars.charAt(((c1 & 0x3)<< 4) | ((c2 & 0xF0) >> 4));
47 | out += base64EncodeChars.charAt((c2 & 0xF) << 2);
48 | out += "=";
49 | break;
50 | }
51 | c3 = str.charCodeAt(i++);
52 | out += base64EncodeChars.charAt(c1 >> 2);
53 | out += base64EncodeChars.charAt(((c1 & 0x3)<< 4) | ((c2 & 0xF0) >> 4));
54 | out += base64EncodeChars.charAt(((c2 & 0xF) << 2) | ((c3 & 0xC0) >>6));
55 | out += base64EncodeChars.charAt(c3 & 0x3F);
56 | }
57 | return out;
58 | }
59 |
60 | function base64decode(str) {
61 | var c1, c2, c3, c4;
62 | var i, len, out;
63 |
64 | len = str.length;
65 | i = 0;
66 | out = "";
67 | while(i < len) {
68 | /* c1 */
69 | do {
70 | c1 = base64DecodeChars[str.charCodeAt(i++) & 0xff];
71 | } while(i < len && c1 == -1);
72 | if(c1 == -1)
73 | break;
74 |
75 | /* c2 */
76 | do {
77 | c2 = base64DecodeChars[str.charCodeAt(i++) & 0xff];
78 | } while(i < len && c2 == -1);
79 | if(c2 == -1)
80 | break;
81 |
82 | out += String.fromCharCode((c1 << 2) | ((c2 & 0x30) >> 4));
83 |
84 | /* c3 */
85 | do {
86 | c3 = str.charCodeAt(i++) & 0xff;
87 | if(c3 == 61)
88 | return out;
89 | c3 = base64DecodeChars[c3];
90 | } while(i < len && c3 == -1);
91 | if(c3 == -1)
92 | break;
93 |
94 | out += String.fromCharCode(((c2 & 0XF) << 4) | ((c3 & 0x3C) >> 2));
95 |
96 | /* c4 */
97 | do {
98 | c4 = str.charCodeAt(i++) & 0xff;
99 | if(c4 == 61)
100 | return out;
101 | c4 = base64DecodeChars[c4];
102 | } while(i < len && c4 == -1);
103 | if(c4 == -1)
104 | break;
105 | out += String.fromCharCode(((c3 & 0x03) << 6) | c4);
106 | }
107 | return out;
108 | }
109 |
110 | if (!window.btoa) window.btoa = base64encode;
111 | if (!window.atob) window.atob = base64decode;
112 |
113 | })();
--------------------------------------------------------------------------------
/websockets/canvas2image.js:
--------------------------------------------------------------------------------
1 | /*
2 | * Canvas2Image v0.1
3 | * Copyright (c) 2008 Jacob Seidelin, cupboy@gmail.com
4 | * MIT License [http://www.opensource.org/licenses/mit-license.php]
5 | */
6 |
7 | var Canvas2Image = (function() {
8 |
9 | // check if we have canvas support
10 | var bHasCanvas = false;
11 | var oCanvas = document.createElement("canvas");
12 | if (oCanvas.getContext("2d")) {
13 | bHasCanvas = true;
14 | }
15 |
16 | // no canvas, bail out.
17 | if (!bHasCanvas) {
18 | return {
19 | saveAsBMP : function(){},
20 | saveAsPNG : function(){},
21 | saveAsJPEG : function(){}
22 | }
23 | }
24 |
25 | var bHasImageData = !!(oCanvas.getContext("2d").getImageData);
26 | var bHasDataURL = !!(oCanvas.toDataURL);
27 | var bHasBase64 = !!(window.btoa);
28 |
29 | var strDownloadMime = "image/octet-stream";
30 |
31 | // ok, we're good
32 | var readCanvasData = function(oCanvas) {
33 | var iWidth = parseInt(oCanvas.width);
34 | var iHeight = parseInt(oCanvas.height);
35 | return oCanvas.getContext("2d").getImageData(0,0,iWidth,iHeight);
36 | }
37 |
38 | // base64 encodes either a string or an array of charcodes
39 | var encodeData = function(data) {
40 | var strData = "";
41 | if (typeof data == "string") {
42 | strData = data;
43 | } else {
44 | var aData = data;
45 | for (var i=0;i object containing the imagedata
156 | var makeImageObject = function(strSource) {
157 | var oImgElement = document.createElement("img");
158 | oImgElement.src = strSource;
159 | return oImgElement;
160 | }
161 |
162 | var scaleCanvas = function(oCanvas, iWidth, iHeight) {
163 | if (iWidth && iHeight) {
164 | var oSaveCanvas = document.createElement("canvas");
165 | oSaveCanvas.width = iWidth;
166 | oSaveCanvas.height = iHeight;
167 | oSaveCanvas.style.width = iWidth+"px";
168 | oSaveCanvas.style.height = iHeight+"px";
169 |
170 | var oSaveCtx = oSaveCanvas.getContext("2d");
171 |
172 | oSaveCtx.drawImage(oCanvas, 0, 0, oCanvas.width, oCanvas.height, 0, 0, iWidth, iWidth);
173 | return oSaveCanvas;
174 | }
175 | return oCanvas;
176 | }
177 |
178 | return {
179 |
180 | saveAsPNG : function(oCanvas, bReturnImg, iWidth, iHeight) {
181 | if (!bHasDataURL) {
182 | return false;
183 | }
184 | var oScaledCanvas = scaleCanvas(oCanvas, iWidth, iHeight);
185 | var strData = oScaledCanvas.toDataURL("image/png");
186 | if (bReturnImg) {
187 | return makeImageObject(strData);
188 | } else {
189 | saveFile(strData.replace("image/png", strDownloadMime));
190 | }
191 | return true;
192 | },
193 |
194 | saveAsJPEG : function(oCanvas, bReturnImg, iWidth, iHeight) {
195 | if (!bHasDataURL) {
196 | return false;
197 | }
198 |
199 | var oScaledCanvas = scaleCanvas(oCanvas, iWidth, iHeight);
200 | var strMime = "image/jpeg";
201 | var strData = oScaledCanvas.toDataURL(strMime);
202 |
203 | // check if browser actually supports jpeg by looking for the mime type in the data uri.
204 | // if not, return false
205 | if (strData.indexOf(strMime) != 5) {
206 | return false;
207 | }
208 |
209 | if (bReturnImg) {
210 | return makeImageObject(strData);
211 | } else {
212 | saveFile(strData.replace(strMime, strDownloadMime));
213 | }
214 | return true;
215 | },
216 |
217 | saveAsBMP : function(oCanvas, bReturnImg, iWidth, iHeight) {
218 |
219 | if (!(bHasImageData && bHasBase64)) {
220 | return false;
221 | }
222 |
223 | var oScaledCanvas = scaleCanvas(oCanvas, iWidth, iHeight);
224 |
225 | var oData = readCanvasData(oScaledCanvas);
226 | var strImgData = createBMP(oData);
227 | if (bReturnImg) {
228 | return makeImageObject(makeDataURI(strImgData, "image/bmp"));
229 | } else {
230 | saveFile(makeDataURI(strImgData, strDownloadMime));
231 | }
232 | return true;
233 | }
234 | };
235 |
236 | })();
--------------------------------------------------------------------------------
/websockets/gameoflife.html:
--------------------------------------------------------------------------------
1 |
2 |
3 | Brian's Brain in Haskell
4 |
5 |
8 |
9 |
10 |
11 |
12 |
13 |
53 |
54 |
55 |
56 |
Brian's Brain
57 |
58 | Brian's Brain is a celluar automaton, similar to the Game of Life, but where each cell can be in one of three states (on / off / dying. In the grid below you can set up a pattern and press play. Communication goes back to a Haskell
59 |
60 |
61 |
62 |
65 |
66 |
67 |
68 |
71 |
72 |
73 |
74 |
75 |
76 |
77 |
78 |
79 |
80 |
81 |
82 |
--------------------------------------------------------------------------------
/websockets/grid.js:
--------------------------------------------------------------------------------
1 | var width;
2 | var height;
3 | var cellSize;
4 | var cellCount;
5 | var grid;
6 | var ctx;
7 | var canvas;
8 |
9 | var OFF = 0;
10 | var ON = 1;
11 | var DYING = 2;
12 |
13 | var isDrawing = false;
14 |
15 | function mouseClickChange() {
16 | isDrawing = !isDrawing;
17 | }
18 |
19 | function mouseMove(e){
20 | if (isDrawing) {
21 | var x = Math.floor((e.clientX - canvas[0].offsetLeft) / cellSize);
22 | var y = Math.floor((e.clientY - canvas[0].offsetTop) / cellSize);
23 | cycle(x,y);
24 | drawGrid();
25 | }
26 | }
27 |
28 | function init(cvs) {
29 | canvas = cvs;
30 | width = canvas.width();
31 | height = canvas.height();
32 | ctx = canvas[0].getContext("2d");
33 | cellSize = 10;
34 |
35 | cellCount = Math.min(width,height) / cellSize;
36 |
37 | grid = new Array(cellCount);
38 | for (i=0;i
2 |
3 | Web Sockets
4 |
5 |
6 |
9 |
10 |
30 |
31 |
32 |
33 |