├── 6502 ├── Example.hs └── Em6502.hs ├── cards ├── Setup.hs ├── src │ └── Main.hs ├── LICENSE └── cards.cabal ├── diamond-square ├── Setup.hs ├── diamond-square.cabal ├── LICENSE └── src │ └── Main.hs ├── azure-event-streams ├── Setup.hs ├── LICENSE ├── azure-event-streams.cabal └── src │ └── Main.hs ├── project-simulator ├── Setup.hs ├── src │ ├── Main.hs │ ├── Projects.hs │ └── Simulate.hs ├── LICENSE └── project-simulator.cabal ├── README ├── .gitignore ├── basics ├── spell.hs ├── realword.hs ├── myfunctions.hs ├── quicksort2.hs ├── datatypes.hs ├── anagrams.hs ├── data.hs ├── tests.hs ├── asciiart.hs ├── randomText.hs └── raytracer.hs ├── freebase ├── static │ ├── albums.css │ └── script.js ├── App.hs └── Freebase.hs ├── misc └── TypeClassopedia.hs ├── spoj └── Fctrl.hs ├── codegolf └── WordFreq.hs ├── daily-programmer ├── 17-03-2015 │ └── RecurrenceRelations.hs └── 18-03-2015 │ └── Irrigation.hs ├── newton ├── OrbitTest.hs ├── Main.hs └── Orbit.hs ├── algorithm-kata └── FrogRiverOne.hs ├── LICENSE ├── kata └── Supermarket │ └── Supermarket.hs ├── websockets ├── websockets.html ├── GameOfLife.hs ├── Web.hs ├── gameoflife.html ├── grid.js ├── base64.js └── canvas2image.js ├── stablemarriage ├── StableMarriage.hs └── Examples.hs ├── arbitrage ├── FloydWarshall.hs ├── FloydWarshallTest.hs └── Forex.hs ├── kepler └── Kepler.chs ├── traffic ├── TrafficVis.hs └── Traffic.hs ├── logparse └── logparse.hs ├── rwh └── ch03.hs ├── chase ├── ChaseVis.hs └── Chase.hs ├── scrabble └── Scrabble.hs ├── ants ├── AntsVis.hs └── Ants.hs ├── dynamicTimeWarping └── DynamicTimeWarping.hs ├── monte-carlo └── WorldCup.hs └── fluidDynamics ├── Main.hs ├── Fluid.hs └── MFluid.hs /cards/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /diamond-square/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /azure-event-streams/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /project-simulator/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | This is just a collection of random code that I'm trying to use to learn Haskell. -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Git ignore file 2 | 3 | *_flymake.hs 4 | .cabal-sandbox 5 | cabal.sandbox.config 6 | **/dist -------------------------------------------------------------------------------- /project-simulator/src/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Projects 4 | 5 | main :: IO () 6 | main = putStrLn "Hello world" 7 | -------------------------------------------------------------------------------- /basics/spell.hs: -------------------------------------------------------------------------------- 1 | import Data.Set (Set) 2 | import qualified Data.Set as Set 3 | 4 | import Data.Map (Map) 5 | import qualified Data.Map as Map 6 | 7 | import List 8 | 9 | wordFile = "/usr/share/dict/words" 10 | 11 | edits :: String -> [String] 12 | edits word = ["Jeff"] 13 | 14 | -------------------------------------------------------------------------------- /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 | } -------------------------------------------------------------------------------- /basics/realword.hs: -------------------------------------------------------------------------------- 1 | 2 | lastButOne :: [a] -> a 3 | lastButOne x:y = x 4 | lastButOne x:y:xs = lastButOne xs 5 | 6 | type CardHolder = String 7 | type CardNumber = String 8 | type Address = [String] 9 | type CustomerID = Int 10 | 11 | data BillingInfo = CreditCard CardNumber CardHolder Address 12 | | CashOnDelivery 13 | | Invoice CustomerID 14 | deriving (Show) -------------------------------------------------------------------------------- /basics/myfunctions.hs: -------------------------------------------------------------------------------- 1 | myadd x y = x + y 2 | 3 | mylength [] count = count 4 | mylength (x:xs) count = mylength xs (1 + count) 5 | 6 | add5 :: [Int] -> [Int] 7 | add5 [] = [] 8 | add5 (x:xs) = (x+5):add5(xs) 9 | 10 | mymap :: (x -> y) -> [x] -> [y] 11 | mymap f [] = [] 12 | mymap f (x:xs) = f x:mymap f xs 13 | 14 | myfilter :: (x -> Bool) -> [x] -> [x] 15 | myfilter f [] = [] 16 | myfilter f (x:xs) | f x = x:myfilter f xs 17 | | otherwise = myfilter f xs -------------------------------------------------------------------------------- /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 | } -------------------------------------------------------------------------------- /basics/quicksort2.hs: -------------------------------------------------------------------------------- 1 | -- The new Dual-Pivot Quicksort uses *two* pivots elements in this manner: 2 | -- 1. Pick an elements P1, P2, called pivots from the array. 3 | -- 2. Assume that P1 <= P2, otherwise swap it. 4 | -- 3. Reorder the array into three parts: those less than the smaller 5 | -- pivot, those larger than the larger pivot, and in between are 6 | -- those elements between (or equal to) the two pivots. 7 | -- 4. Recursively sort the sub-arrays. 8 | 9 | dualPivotQuickSort :: Ord(a) => [a] -> [a] 10 | dualPivotQuickSort = undefined 11 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /basics/datatypes.hs: -------------------------------------------------------------------------------- 1 | -- Goal to investigate some data types 2 | 3 | -- This is called a product type 4 | data Point = Point { x :: Float 5 | , y :: Float } deriving (Show, Eq) 6 | 7 | {-- 8 | Main> Point 3.0 4.0 == Point 1.0 2.0 9 | 10 | :1:0: 11 | No instance for (Eq Point) 12 | arising from a use of `==' at :1:0-29 13 | Possible fix: add an instance declaration for (Eq Point) 14 | In the expression: Point 3.0 4.0 == Point 1.0 2.0 15 | In the definition of `it': it = Point 3.0 4.0 == Point 1.0 2.0 16 | --} 17 | 18 | 19 | -------------------------------------------------------------------------------- /6502/Example.hs: -------------------------------------------------------------------------------- 1 | module Example where 2 | 3 | import Em6502 4 | import Data.IORef 5 | 6 | main :: IO () 7 | main = do 8 | cpu <- mkCPU -- Create a blank CPU 9 | writeIORef (ac cpu) 4 -- store 4 in the accumulator 10 | let instructions = [ASL Accumulator 11 | ,STA (Absolute 1024) 12 | ,ASL Accumulator 13 | ,ASL Accumulator 14 | ,CLC 15 | ,ADC (Absolute 1024)] 16 | runInstructions cpu instructions 17 | ac' <- readIORef (ac cpu) 18 | word <- readWord cpu 1024 19 | print ac' 20 | return () -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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) -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /basics/anagrams.hs: -------------------------------------------------------------------------------- 1 | -- Some simple functions to generate anagrams of words 2 | import Data.Char 3 | import List 4 | 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | 8 | import Data.Map (Map) 9 | import qualified Data.Map as Map 10 | 11 | wordfile = "/usr/share/dict/words" 12 | 13 | stringToKey :: String -> String 14 | stringToKey = sort.(map toLower) 15 | 16 | validWord :: String -> Bool 17 | validWord s = (not (null s)) && 18 | length s <= 10 && 19 | not (any (not.isAlpha) s) 20 | 21 | anagramList :: String -> IO (Map String (Set String)) 22 | anagramList file = do 23 | filecontent <- readFile file 24 | return (foldl (\x y -> Map.insertWith Set.union (stringToKey y) (Set.singleton y) x) 25 | Map.empty 26 | (filter validWord $ lines filecontent)) 27 | 28 | anagramsOf :: String -> IO () 29 | anagramsOf word = do 30 | anagrams <- anagramList wordfile 31 | putStrLn (show (Map.lookup (stringToKey word) anagrams)) 32 | -------------------------------------------------------------------------------- /cards/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | import Network.Wai 4 | import Network.Wai.Handler.Warp 5 | import Network.HTTP.Types (status200) 6 | import Blaze.ByteString.Builder (copyByteString) 7 | import qualified Data.ByteString.UTF8 as BU 8 | import Data.Monoid 9 | 10 | main :: IO () 11 | main = do 12 | let port = 3000 13 | putStrLn $ "Listening on port " ++ show port 14 | run port app 15 | 16 | app :: Request -> (Response -> t) -> t 17 | app req respond = respond $ 18 | case pathInfo req of 19 | ["yay"] -> yay 20 | x -> index x 21 | 22 | yay :: Response 23 | yay = responseBuilder status200 [ ("Content-Type", "text/plain") ] $ mconcat $ map copyByteString 24 | [ "yay" ] 25 | 26 | index :: Show a => a -> Response 27 | index x = responseBuilder status200 [("Content-Type", "text/html")] $ mconcat $ map copyByteString 28 | [ "

    Hello from ", BU.fromString $ show x, "!

    " 29 | , "

    yay

    \n" ] 30 | -------------------------------------------------------------------------------- /basics/data.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map as Map 2 | import Test.BenchPress 3 | import System.Random 4 | import Maybe 5 | 6 | alist :: [(String,Double)] 7 | alist = [("pi", 3.14159265), ("e", 2.71828183), ("phi", 1.61803398874)] 8 | 9 | getConstant :: String -> Maybe Double 10 | getConstant name = lookup name alist 11 | 12 | listSize = 10000; 13 | 14 | bigList :: Integer -> [(Integer,Integer)] 15 | bigList n = map (\x -> (x, x*2)) [1..n] 16 | 17 | randomLookup l = do 18 | r1 <- getStdGen 19 | let (x, r2) = randomR (0,listSize) r1 20 | setStdGen r2 21 | return (lookup x l) 22 | 23 | timeLookups :: IO () 24 | timeLookups = let exampleList = (bigList listSize) in 25 | bench 100 $ do 26 | a <- randomLookup (bigList listSize) 27 | putStr (show a) 28 | return () 29 | 30 | -- Association lists are O(N) lookup via a linear scan 31 | -- Maps are O(1) lookup 32 | 33 | mlist :: Map.Map String Double 34 | mlist = Map.fromList alist 35 | 36 | mlist2 :: Map.Map String Double 37 | mlist2 = Map.insert "pi" 3.14159265 $ Map.empty -------------------------------------------------------------------------------- /cards/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Jeff Foster 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /azure-event-streams/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015 Jeff Foster 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /cards/cards.cabal: -------------------------------------------------------------------------------- 1 | -- Initial cards.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: cards 5 | version: 0.1.0.0 6 | synopsis: A cards API (stealing someone elses idea) 7 | -- description: 8 | homepage: http://www.fatvat.co.uk/ 9 | license: MIT 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 cards 20 | main-is: Main.hs 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >=4.8 && <4.9, 24 | warp >= 3.0, 25 | wai >= 3.0.2, 26 | http-types >= 0.8.6, 27 | blaze-builder >= 0.4.0.1, 28 | bytestring >= 0.10.6, 29 | utf8-string >= 1 30 | hs-source-dirs: src 31 | default-language: Haskell2010 -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /algorithm-kata/FrogRiverOne.hs: -------------------------------------------------------------------------------- 1 | module FrogRiverOne where 2 | 3 | {- A small frog wants to get to the other side of a river. The frog is initially located on one bank of the river (position 0) and wants to get to the opposite bank (position X+1). Leaves fall from a tree onto the surface of the river. 4 | 5 | You are given a zero-indexed array A consisting of N integers representing the falling leaves. A[K] represents the position where one leaf falls at time K, measured in seconds. 6 | 7 | The goal is to find the earliest time when the frog can jump to the other side of the river. The frog can cross only when leaves appear at every position across the river from 1 to X (that is, we want to find the earliest moment when all the positions from 1 to X are covered by leaves). You may assume that the speed of the current in the river is negligibly small, i.e. the leaves do not change their positions once they fall in the river. -} 8 | 9 | import Data.Bits (setBit) 10 | import Data.List (elemIndex) 11 | 12 | solve :: Int -> [Int] -> Maybe Int 13 | solve a xs = elemIndex ((2^a) - 1) pop 14 | where 15 | pop :: [Integer] 16 | pop = scanl setBit 1 xs 17 | 18 | exampleA :: [Int] 19 | exampleA = [1,3,1,4,2,3,5,4] 20 | 21 | 22 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /basics/tests.hs: -------------------------------------------------------------------------------- 1 | import Test.HUnit 2 | 3 | import Test.QuickCheck 4 | 5 | foo :: (Num a) => a -> a -> a -> a 6 | foo a b c = a * b + c 7 | 8 | test1 = TestCase (assertEqual "* has higher precedence" 26 (foo 2 10 6)) 9 | 10 | tests = TestList [TestLabel "Foo test" test1] 11 | 12 | addNum :: (Num a) => a -> a -> a 13 | addNum a b = a + b 14 | 15 | invariantAddNum a b = (addNum a b) >= b && (addNum a b) >= a 16 | 17 | data Point = Point {x :: Float , y :: Float} deriving Show 18 | 19 | square :: (Num a) => a -> a 20 | square x = x * x 21 | 22 | distance :: Point -> Point -> Float 23 | distance p1 p2 = sqrt(square ((x p1)-(x p2)) + square ((y p1)-(y p2))) 24 | 25 | prop_distance ::Point -> Point -> Float -> Float -> Bool 26 | prop_distance p1 p2 d1 d2 = 0.001 > abs (distance p1 p2 - 27 | distance (Point ((x p1) + d1) ((y p1) + d2)) 28 | (Point ((x p2) + d1) ((y p2) + d2))) 29 | 30 | instance Arbitrary Point where 31 | arbitrary = do 32 | x <- choose(1,1000) :: Gen Float 33 | y <- choose(1,1000) :: Gen Float 34 | return (Point x y) 35 | 36 | groupN :: [a] -> Int -> [[a]] 37 | groupN [] _ = [] 38 | groupN xs n = a : groupN b n where 39 | (a,b) = splitAt n xs 40 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Jeff Foster 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /websockets/websockets.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | Web Sockets 4 | 5 | 6 | 9 | 10 | 30 | 31 | 32 | 33 |

    I'm doing something

    34 | 35 |
    36 |
    37 | 38 |
    39 |
    40 | 41 | 44 | 45 |
    46 | 47 | 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /azure-event-streams/azure-event-streams.cabal: -------------------------------------------------------------------------------- 1 | -- Initial azure-event-streams.cabal generated by cabal init. For further documentation, 2 | -- see http://haskell.org/cabal/users-guide/ 3 | 4 | name: azure-event-streams 5 | version: 0.1.0.0 6 | synopsis: A azure-event-streams API (stealing someone elses idea) 7 | -- description: 8 | homepage: http://www.fatvat.co.uk/ 9 | license: MIT 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 azure-event-streams 20 | main-is: Main.hs 21 | -- other-modules: 22 | -- other-extensions: 23 | build-depends: base >=4.8 && <4.9, 24 | http-types >= 0.8.6, 25 | network-uri >= 2.6, 26 | SHA >= 1.6.4.2, 27 | time >= 1.5.0.1, 28 | bytestring >= 0.10.6.0, 29 | base64-bytestring >= 1.0.0.1, 30 | http-streams >= 0.8.3.3, 31 | io-streams >= 1.3.1.0, 32 | blaze-builder >= 0.4.0.1, 33 | aeson >= 0.9.0.1 34 | hs-source-dirs: src 35 | default-language: Haskell2010 -------------------------------------------------------------------------------- /basics/asciiart.hs: -------------------------------------------------------------------------------- 1 | -- Quick Program to generate some ASCII art based on PPM files 2 | 3 | import Graphics.Pgm 4 | 5 | import Text.Parsec.Error 6 | import Data.Array.Base 7 | 8 | import Data.List.Split 9 | 10 | brightness = " .`-_':,;^=+/\"|)\\<>)iv%xclrs{*}I?!][1taeo7zjLu" ++ 11 | "nT#JCwfy325Fp6mqSghVd4EgXPGZbYkOA&8U$@KHDBWNMR0Q"; 12 | 13 | -- | Load the first image from the specified PGM file 14 | loadImage :: String -> IO (UArray (Int,Int) Int) 15 | loadImage path = do 16 | r <- pgmsFromFile path 17 | case r of 18 | Left e -> error "Failed to parse file" 19 | Right i -> return (head i) 20 | 21 | brightnessToChar :: Int -> Int -> Char 22 | brightnessToChar m b = brightness !! 23 | (round ((fromIntegral b) / (fromIntegral m) * (fromIntegral ((length brightness) - 1)))) 24 | 25 | imageToAscii :: UArray (Int,Int) Int -> UArray (Int,Int) Char 26 | imageToAscii image = amap (brightnessToChar 255) image 27 | 28 | convertImage :: String -> String -> IO () 29 | convertImage image out = do 30 | img <- loadImage image 31 | let ((_,_),(h,w)) = bounds img 32 | let x = imageToAscii img 33 | writeFile "/home/jfoster/Desktop/jeff.txt" ([ x ! (i,j) | j <- [0..w], i <- [0..h]]) 34 | writeFile out (unlines [ [ x ! (i,j) | i <- [0..w] ] | j <- [0..h] ]) 35 | return () 36 | 37 | 38 | 39 | 40 | 41 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /basics/randomText.hs: -------------------------------------------------------------------------------- 1 | import Data.Map (Map) 2 | import Data.Foldable 3 | import Data.List (unwords) 4 | import qualified Data.Map as Map 5 | 6 | import System.Random 7 | 8 | type Followers = Map String Int 9 | type WordSuccessors = Map String Followers 10 | 11 | exampleFile :: FilePath 12 | exampleFile = "/home/jfoster/example.txt" 13 | 14 | createTrainingSet :: String -> WordSuccessors 15 | createTrainingSet s = foldl' updateMap Map.empty (wordPairs (words s)) 16 | 17 | -- If we've seen the word before then we need to +1 to the key 18 | updateMap :: WordSuccessors -> (String,String) -> WordSuccessors 19 | updateMap m (x,y) = Map.insert x v m where 20 | q = Map.findWithDefault (Map.singleton y 0) x m 21 | v = Map.insert y (succ (Map.findWithDefault 0 y q)) q 22 | 23 | wordPairs :: [String] -> [(String,String)] 24 | wordPairs l = zip l (tail l) 25 | 26 | -- Remember, use "it" for last value in ghci 27 | -- Use :info to print out type defs 28 | 29 | -- TODO This algorithm is stupidly bad - the second data structure (Map Int String) is 30 | -- completely wrong. It should be something many times more efficient 31 | nextWord :: [Int] -> WordSuccessors -> String -> ([Int],String) 32 | nextWord seeds fm start = (r, (poss !! (mod s count))) where 33 | successors = fm Map.! start 34 | count = Map.fold (+) 0 successors 35 | poss = Map.foldWithKey (\k v acc -> (replicate v k) ++ acc) [] successors 36 | s = head seeds 37 | r = drop 1 seeds 38 | 39 | maxWordCount :: Int 40 | maxWordCount = 1000000 41 | 42 | main :: IO(String) 43 | main = do 44 | text <- readFile exampleFile 45 | gen <- newStdGen 46 | let training = createTrainingSet text 47 | seeds = randomRs (0,maxWordCount) gen 48 | return (unwords (map snd (iterate (\(s,w) -> nextWord s training w) (seeds,"by")))) 49 | 50 | 51 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | 63 | Your browser does not support canvas 64 | 65 | 66 |
    67 | 68 | 71 | 72 |
    73 | 74 |
    75 | 76 |
    77 | 78 |
    79 | 80 | 81 | 82 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /arbitrage/FloydWarshall.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FunctionalDependencies #-} 3 | 4 | module FloydWarshall where 5 | 6 | import Data.Maybe 7 | import Data.Array 8 | 9 | class Enum b => Graph a b | a -> b where 10 | vertices :: a -> [b] 11 | edge :: a -> b -> b -> Maybe Double 12 | fromInt :: a -> Int -> b 13 | 14 | -- An arbitrary representation of infinity! 15 | infinity :: Double 16 | infinity = 10000000 17 | 18 | findArbitrage :: Graph a b => a -> Maybe [b] 19 | findArbitrage g | Nothing == maybePath = Nothing 20 | | otherwise = Just sq 21 | where 22 | res = floydWarshall g 23 | maybePath = arbChances res 24 | sq = map (fromInt g) (steps res (fst $ fromJust maybePath)) 25 | 26 | -- When the steps is zero it's simply the edge weights 27 | type FWResult = Array (Int,Int,Int) (Double,Int) 28 | 29 | floydWarshall :: Graph a b => a -> FWResult 30 | floydWarshall g = arr 31 | where 32 | arr = array ((0,0,0),(n,n,n)) [((m,i,j),f m i j) | 33 | m <- [0..n], 34 | i <- [0..n], 35 | j <- [0..n]] 36 | n = length (vertices g) - 1 37 | f = floydWarshallStep g arr 38 | 39 | 40 | floydWarshallStep :: Graph a b => a -> FWResult -> Int -> Int -> Int -> (Double,Int) 41 | 42 | -- |The base case simply initializes to the edges 43 | floydWarshallStep g _ 0 i j | i == j = (1.0,-1) 44 | | otherwise = (d,-1) 45 | where 46 | w = edge g (fromInt g i) (fromInt g j) 47 | d = maybe infinity (const (fromJust w)) w 48 | 49 | -- |The recursive case is defined in terms of the previous ones 50 | floydWarshallStep g a m i j = foldl f (0.0,-1) [0..n] 51 | where 52 | n = length (vertices g) - 1 53 | f :: (Double,Int) -> Int -> (Double,Int) 54 | f (b,p) k | b < (mik*okj) = (mik*okj,k) 55 | | otherwise = (b,p) 56 | where 57 | mik = fst $ a ! (m-1,i,k) 58 | okj = fst $ a ! (0,k,j) 59 | 60 | 61 | arbChances :: FWResult -> Maybe ((Int,Int,Int),(Double,Int)) 62 | arbChances a | null c = Nothing 63 | | otherwise = Just (head c) 64 | where 65 | c = filter (\((s,i,j),(best,_)) -> s >= 1 && i == j && best > 1.01 && best < infinity) 66 | (assocs a) 67 | 68 | steps :: FWResult -> (Int,Int,Int) -> [Int] 69 | steps a (s,i,j) = reverse $ i : x : steps' a (s - 1,i,x) ++ [i] 70 | where 71 | x = snd $ a ! (s,i,j) 72 | 73 | steps' :: FWResult -> (Int,Int,Int) -> [Int] 74 | steps' _ (0,_,_) = [] 75 | steps' a (s,i,j) = p : steps' a (s-1,i,p) 76 | where 77 | p = snd $ a ! (s,i,j) 78 | 79 | 80 | 81 | -------------------------------------------------------------------------------- /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 [Unit] 28 | vertices' (Exchange d) = nub $ map snd (keys d) 29 | 30 | edge' :: Exchange -> Unit -> Unit -> Maybe Double 31 | edge' (Exchange d) x y = Map.lookup (x,y) d 32 | 33 | fromInt' :: Exchange -> Int -> Unit 34 | fromInt' _ = toEnum 35 | 36 | basicExchangeData :: Exchange 37 | basicExchangeData = Exchange (Map.fromList d) 38 | where 39 | d = [((A,B), 1.2) 40 | ,((A,C), 0.89) 41 | ,((B,A), 0.88) 42 | ,((B,C), 5.10) 43 | ,((C,A), 1.1) 44 | ,((C,B), 0.15)] 45 | 46 | moreComplex :: Exchange 47 | moreComplex = Exchange (Map.fromList d) 48 | where 49 | d = [((A,B), 3.1) 50 | ,((A,C), 0.0023) 51 | ,((A,D), 0.35) 52 | ,((B,A), 0.21) 53 | ,((B,C), 0.00353) 54 | ,((B,D), 8.13) 55 | ,((C,A), 200) 56 | ,((C,B), 180.559) 57 | ,((C,D), 10.339) 58 | ,((D,A), 2.11) 59 | ,((D,B), 0.089) 60 | ,((D,C), 0.06111)] 61 | 62 | noOpportunity :: Exchange 63 | noOpportunity = Exchange (Map.fromList d) 64 | where 65 | d = [((A,B), 2.0), ((B,A), 0.45)] 66 | 67 | simpleOpportunity :: Exchange 68 | simpleOpportunity = Exchange (Map.fromList d) 69 | where 70 | d = [((A,B), 1.1), ((B,A), 0.95)] 71 | 72 | test1 :: Test 73 | test1 = TestCase (do 74 | assertEqual "Basic test case 1" (Just [A,B,A]) (findArbitrage basicExchangeData) 75 | assertBool "Makes money" (runOpportunity basicExchangeData [A,B,A] > 1.0)) 76 | 77 | test2 :: Test 78 | test2 = TestCase (do 79 | assertEqual "Basic test case 1" (Just [A,B,D,A]) (findArbitrage moreComplex) 80 | assertBool "Makes money" (runOpportunity moreComplex [A,B,D,A] > 1.0)) 81 | 82 | test3 :: Test 83 | test3 = TestCase (assertEqual "Basic test case 1" Nothing (findArbitrage noOpportunity)) 84 | 85 | test4 :: Test 86 | test4 = TestCase (do 87 | assertEqual "Basic test case 1" (Just [A,B,A]) (findArbitrage simpleOpportunity) 88 | assertBool "Makes money" (runOpportunity simpleOpportunity [A,B,A] > 1.0)) 89 | 90 | tests :: Test 91 | tests = TestList [TestLabel "test1" test1 92 | ,TestLabel "test2" test2 93 | ,TestLabel "test3" test3 94 | ,TestLabel "test4" test4] 95 | 96 | -- If there is an opportunity it should make money! 97 | runOpportunity :: Exchange -> [Unit] -> Double 98 | runOpportunity (Exchange m) x = product $ catMaybes (map (flip Map.lookup m) (zip x (tail x))) 99 | 100 | 101 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | })(); -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /azure-event-streams/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | import Network.URI 5 | import Data.Time.Clock.POSIX 6 | import Data.Digest.Pure.SHA 7 | import Data.ByteString.Char8 (ByteString) 8 | import qualified Data.ByteString.Char8 as B 9 | import qualified Data.ByteString.Lazy.Char8 as LB 10 | import qualified Data.ByteString.Base64 as Base64 11 | import Data.Maybe (fromJust, fromMaybe) 12 | import Data.List (genericLength) 13 | 14 | import System.IO.Streams (InputStream, OutputStream, stdout) 15 | import qualified System.IO.Streams as Streams 16 | import Network.Http.Client 17 | import qualified Blaze.ByteString.Builder.ByteString as Builder 18 | 19 | import Data.Aeson (FromJSON, ToJSON, decode, encode) 20 | import GHC.Generics (Generic) 21 | 22 | data AccessKey = AccessKey 23 | { 24 | keyName :: ByteString 25 | , key :: ByteString 26 | } deriving (Show,Eq) 27 | 28 | type Token = ByteString 29 | 30 | 31 | data Sample = Sample 32 | { 33 | name :: String, 34 | value :: Double 35 | } deriving (Show, Generic) 36 | 37 | data Event = Event 38 | { 39 | device :: String 40 | , samples :: [Sample] 41 | } deriving (Show, Generic) 42 | 43 | instance ToJSON Sample 44 | instance ToJSON Event 45 | 46 | 47 | namespace :: ByteString 48 | namespace = "eventhubexample-ns" 49 | 50 | hubName :: ByteString 51 | hubName = "eventhubexample" 52 | 53 | deviceName :: ByteString 54 | deviceName = "computer" 55 | 56 | encodeURI :: URI -> ByteString 57 | encodeURI x = B.pack $ uriToString id x "" 58 | 59 | -- This function validates against the JS thing 60 | sign :: ByteString -> ByteString -> ByteString 61 | sign key signingString = Base64.encode $ LB.toStrict $ bytestringDigest dig 62 | where 63 | strictKey = LB.fromStrict key 64 | strictString = LB.fromStrict signingString 65 | dig = hmacSha256 strictKey strictString 66 | 67 | escape :: ByteString -> ByteString 68 | escape = B.pack . escapeURIString isUnreserved . B.unpack 69 | 70 | buildUri :: ByteString -> ByteString -> Integer -> ByteString -> ByteString 71 | buildUri uri signature expiry keyName = B.concat [ 72 | "SharedAccessSignature sr=", 73 | uri, 74 | "&sig=", 75 | escape signature, 76 | "&se=", 77 | B.pack $ show expiry, 78 | "&skn=", 79 | keyName 80 | ] 81 | 82 | createSASToken :: URI -> AccessKey -> IO Token 83 | createSASToken uri accessKey = do 84 | expiry <- (+ 3600) `fmap` round `fmap` getPOSIXTime 85 | let name = keyName accessKey 86 | encodedURI = escape $ B.pack $ show uri 87 | stringToSign = B.concat [ 88 | encodedURI, 89 | "\n", 90 | B.pack $ show expiry 91 | ] 92 | signature = sign (key accessKey) stringToSign 93 | 94 | return $ buildUri encodedURI signature expiry name 95 | 96 | makeRequest :: ToJSON a => AccessKey -> a -> IO () 97 | makeRequest key obj = do 98 | token <- createSASToken url key 99 | 100 | let contentType = "application/atom+xml;type=entry;charset=utf-8" 101 | messageBody = encode obj 102 | q = buildRequest1 $ do 103 | http POST (B.pack $ show url) 104 | setAccept "application/json" 105 | setContentType contentType 106 | setContentLength (fromIntegral $ LB.length messageBody) 107 | setHeader "Authorization" token 108 | 109 | c <- withConnection (establishConnection (B.pack $ show url)) $ (\c -> do 110 | sendRequest c q (\o -> Streams.write (Just (Builder.fromLazyByteString messageBody)) o) 111 | receiveResponse c debugHandler) 112 | 113 | return () 114 | 115 | 116 | url :: URI 117 | url = fromJust $ parseURI $ B.unpack $ B.concat ["https://", namespace, ".servicebus.windows.net", "/", hubName, "/publishers/", deviceName, "/messages"] 118 | 119 | main :: IO () 120 | main = do 121 | return () 122 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 | --} -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /basics/raytracer.hs: -------------------------------------------------------------------------------- 1 | import Maybe 2 | import List 3 | 4 | import Data.Word 5 | import Data.Array 6 | 7 | import Graphics.Pgm 8 | 9 | data Point = Point { x :: Float 10 | , y :: Float 11 | , z :: Float 12 | } deriving (Show) 13 | 14 | data Sphere = Sphere { color :: Float 15 | , radius :: Float 16 | , centre :: Point 17 | } deriving (Show) 18 | 19 | data ObjectHit = ObjectHit { object :: Sphere 20 | , location :: Point 21 | } deriving (Show) 22 | 23 | data Brightness = Brightness { value :: Float } deriving (Show) 24 | 25 | square :: (Num a) => a -> a 26 | square x = x * x 27 | 28 | magnitude :: Point -> Float 29 | magnitude p = sqrt ((square (x p)) + (square (y p)) + (square (z p))) 30 | 31 | unitVector :: Point -> Point 32 | unitVector p = let d = magnitude p 33 | in Point ((x p)/d) ((y p)/d) ((z p)/d) 34 | 35 | pointSubtract :: Point -> Point -> Point 36 | pointSubtract p1 p2 = Point (x p1-x p2) (y p1-y p2) (z p1-z p2) 37 | 38 | distance :: Point -> Point -> Float 39 | distance p1 p2 = magnitude (pointSubtract p1 p2) 40 | 41 | sphereNormal :: Sphere -> Point -> Point 42 | sphereNormal s p = unitVector (pointSubtract (centre s) p) 43 | 44 | lambert :: Sphere -> Point -> Point -> Float 45 | lambert s i r = let n = sphereNormal s i 46 | in max 0 ((x r * x n) + (y r * y n) + (z r * z n)) 47 | 48 | minroot :: Float -> Float -> Float -> Maybe Float 49 | minroot a b c 50 | | a == 0 = Just ((- c) / b) 51 | | otherwise = let disc = (square b) - (4 * a * c) 52 | in if (disc > 0) 53 | then Just (min (((-b) + sqrt disc) / (2 * a)) (((-b) - sqrt disc) / (2 * a))) 54 | else Nothing 55 | 56 | sphereIntersect :: Sphere -> Point -> Point -> Maybe ObjectHit 57 | sphereIntersect s pt r = let c = centre s 58 | n = minroot (square (x r) + square (y r) + square (z r)) 59 | (2 * ((x r * (x pt - x c)) + (y r * (y pt - y c)) + (z r * (z pt - z c)))) 60 | ((square (x pt - x c)) + (square (y pt - y c)) + (square (z pt - z c)) - (square (radius s))) 61 | in if (isNothing n) 62 | then Nothing 63 | else Just (ObjectHit 64 | s 65 | (Point 66 | ((x pt) + (fromJust n) * (x r)) 67 | ((y pt) + (fromJust n) * (y r)) 68 | ((z pt) + (fromJust n) * (z r)))) 69 | 70 | spheresHit :: [Sphere] -> Point -> Point -> [ObjectHit] 71 | spheresHit sw pt r = mapMaybe (\x -> sphereIntersect x pt r) sw 72 | 73 | nearestHit :: [Sphere] -> Point -> Point -> Maybe ObjectHit 74 | nearestHit sp pt r = let hitSpheres = spheresHit sp pt r 75 | in 76 | case hitSpheres of 77 | [] -> Nothing 78 | x -> Just (head (sortBy 79 | (\h1 h2 -> (compare (distance (location h1) pt) (distance (location h2) pt))) 80 | x)) 81 | 82 | sendRay :: [Sphere] -> Point -> Point -> Brightness 83 | sendRay world src ray = let hit = nearestHit world src ray 84 | in if (isNothing hit) 85 | then (Brightness 0) 86 | else let sp = object (fromJust hit) in 87 | (Brightness ((color sp) * (lambert sp src ray))) 88 | 89 | colorAt :: [Sphere] -> Point -> Float -> Float -> Brightness 90 | colorAt world eye x y = let ray = unitVector (pointSubtract (Point x y 0) eye) 91 | in (Brightness (255 * value (sendRay world eye ray))) 92 | 93 | exampleEye :: Point 94 | exampleEye = (Point 150 150 200) 95 | 96 | exampleWorld :: [Sphere] 97 | exampleWorld = [Sphere 0.32 250 (Point 150 150 (-600)), 98 | Sphere 0.64 100 (Point 175 175 (-300))] 99 | 100 | image :: [Sphere] -> Point -> Int -> Int -> Array (Int,Int) Int 101 | image world eye width height = 102 | array 103 | ((0,0),(width,height)) 104 | [((i,j),truncate (255 * (value (colorAt world eye (fromIntegral i) (fromIntegral j))))) | 105 | i <- [0..width], j<- [0..height]] 106 | 107 | imageWord16 :: Array (Int,Int) Int -> Array (Int,Int) Word16 108 | imageWord16 image = fmap (fromIntegral :: Int -> Word16) image 109 | 110 | saveImage :: String -> [Sphere] -> Point -> Int -> Int -> IO () 111 | saveImage filename world eye width height = arrayToFile filename (imageWord16 (image world eye width height)) -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 | -} -------------------------------------------------------------------------------- /ants/AntsVis.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module AntsVis where 3 | 4 | import Ants 5 | 6 | import System.Exit (exitWith, ExitCode(ExitSuccess)) 7 | import System.Random 8 | 9 | import Graphics.UI.GLUT as G 10 | import Data.Maybe (fromJust) 11 | 12 | import Data.Vector (Vector) 13 | import qualified Data.Vector as V 14 | 15 | import Control.Monad 16 | import Control.Concurrent 17 | import Control.Concurrent.STM 18 | 19 | import Debug.Trace 20 | 21 | color4f :: Color4 GLfloat -> IO () 22 | color4f = color 23 | 24 | vertex2f :: Vertex2 GLfloat -> IO () 25 | vertex2f = vertex :: Vertex2 GLfloat -> IO () 26 | 27 | colorVertex :: Color4 GLfloat -> Vertex2 GLfloat -> IO () 28 | colorVertex c v = do 29 | color4f c 30 | vertex v 31 | 32 | --pos :: Vector (Int,Int) 33 | --pos = V.fromList [(y,x) | x <- [0..dim-1], y <- [0..dim-1]] 34 | 35 | antBehave :: World -> (Int,Int) -> IO () 36 | antBehave world p = do 37 | gen <- newStdGen 38 | newPos <- atomically $ behave gen world p 39 | _ <- threadDelay (antTick * 1000) 40 | antBehave world newPos 41 | 42 | evaporateWorld :: World -> IO () 43 | evaporateWorld w = do 44 | evaporate w 45 | _ <- threadDelay (evapTick * 1000) 46 | evaporateWorld w 47 | 48 | -- |Timeout in ms for the callback 49 | tick :: Int 50 | tick = 50 51 | 52 | -- |Timeout for the ants 53 | antTick :: Int 54 | antTick = 100 55 | 56 | -- |Evaporation time 57 | evapTick :: Int 58 | evapTick = 100 59 | 60 | gridSize :: GLfloat 61 | gridSize = 7 62 | 63 | pherScale :: GLfloat 64 | pherScale = 40.0 65 | 66 | foodScale :: GLfloat 67 | foodScale = 100.0 68 | 69 | antInfo :: Direction -> (GLfloat,GLfloat,GLfloat,GLfloat) 70 | antInfo N = (2,0,2,4) 71 | antInfo NE = (4,0,0,4) 72 | antInfo E = (4,2,0,2) 73 | antInfo SE = (4,4,0,0) 74 | antInfo Ants.S = (2,4,2,0) -- what is the S from Graphics.UI.Glut? 75 | antInfo SW = (0,4,4,0) 76 | antInfo W = (0,2,4,2) 77 | antInfo NW = (0,0,4,4) 78 | 79 | displayFunc :: World -> DisplayCallback 80 | displayFunc world = do 81 | clear [ColorBuffer] 82 | 83 | let h = fromIntegral homeOff * gridSize 84 | g = gridSize + gridSize * fromIntegral nantsSqrt 85 | renderPrimitive Quads $ do 86 | colorVertex (Color4 0 0 1 0.1) (Vertex2 h h) 87 | colorVertex (Color4 0 0 1 0.1) (Vertex2 (h+g) h) 88 | colorVertex (Color4 0 0 1 0.1) (Vertex2 (h+g) (h+g)) 89 | colorVertex (Color4 0 0 1 0.1) (Vertex2 h (h+g)) 90 | forM_ [0..dim*dim] (\x -> let pos = (x `div` dim, x `mod` dim) in drawPlace pos (world V.! x)) 91 | swapBuffers 92 | 93 | timerFunc :: World -> IO () 94 | timerFunc w = do 95 | postRedisplay Nothing 96 | addTimerCallback tick (timerFunc w) 97 | return () 98 | 99 | drawAnt :: (Int,Int) -> Ant -> IO () 100 | drawAnt (x,y) a = do 101 | let gray = Color4 0.4 0.4 0.4 1 :: Color4 GLfloat 102 | red = Color4 1 0 0 1 :: Color4 GLfloat 103 | (hx,hy,tx,ty) = antInfo (direction a) 104 | c = if hasFood a 105 | then red 106 | else gray 107 | x' = fromIntegral x * gridSize 108 | y' = fromIntegral y * gridSize 109 | 110 | renderPrimitive Lines $ do 111 | colorVertex c (Vertex2 (hx + x') (hy + y')) 112 | colorVertex c (Vertex2 (tx + x') (ty + y')) 113 | return () 114 | 115 | fillCell :: (Int,Int) -> Color4 GLfloat -> IO () 116 | fillCell (i,j) c = do 117 | let x = fromIntegral i * gridSize 118 | y = fromIntegral j * gridSize 119 | renderPrimitive Quads $ do 120 | colorVertex c (Vertex2 x y) 121 | colorVertex c (Vertex2 (x + gridSize) y) 122 | colorVertex c (Vertex2 (x + gridSize) (y + gridSize)) 123 | colorVertex c (Vertex2 x (y + gridSize)) 124 | 125 | drawPlace :: (Int,Int) -> TCell -> IO () 126 | drawPlace loc tcell = do 127 | cell <- atomically $ readTVar tcell 128 | when (pher cell > 0) 129 | (fillCell loc (Color4 0 (min 1 (realToFrac (pher cell) / pherScale)) 0 0)) 130 | when (food cell > 0) 131 | (fillCell loc (Color4 (min 1 (fromIntegral (food cell) / foodScale)) 0 0 0)) 132 | when (hasAnt cell) 133 | (drawAnt loc (fromJust $ ant cell)) 134 | 135 | reshapeFunc :: ReshapeCallback 136 | reshapeFunc size@(Size _ height) = 137 | unless (height == 0) $ do 138 | viewport $= (Position 0 0, size) 139 | matrixMode $= Projection 140 | loadIdentity 141 | ortho2D 0 400 0 400 142 | 143 | keyboardMouseHandler :: KeyboardMouseCallback 144 | keyboardMouseHandler (Char 'q') Down _ _ = exitWith ExitSuccess 145 | keyboardMouseHandler _ _ _ _ = return () 146 | 147 | main :: IO () 148 | main = do 149 | _ <- getArgsAndInitialize 150 | initialDisplayMode $= [DoubleBuffered,WithAlphaComponent,RGBAMode] 151 | initialWindowSize $= Size 512 512 152 | initialWindowPosition $= Position 0 0 153 | createWindow "Ants in Haskell." 154 | clearColor $= Color4 0 0 0 0 155 | 156 | (w,ants) <- mkWorld 157 | 158 | forM_ ants (\x -> forkIO $ antBehave w x >> return ()) 159 | forkIO $ evaporateWorld w 160 | 161 | displayCallback $= displayFunc w 162 | reshapeCallback $= Just reshapeFunc 163 | addTimerCallback tick (timerFunc w) 164 | keyboardMouseCallback $= Just keyboardMouseHandler 165 | 166 | mainLoop 167 | -------------------------------------------------------------------------------- /arbitrage/Forex.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | module Forex (main) where 3 | 4 | import Text.ParserCombinators.Parsec (endBy,sepBy,char,many,noneOf,string,parse) 5 | import Text.Parsec.ByteString.Lazy 6 | import Control.Monad (liftM,liftM2,liftM5) 7 | import Data.Time.Clock 8 | import Data.Time.Format (parseTime) 9 | import Data.Maybe 10 | import Data.Ix 11 | import qualified Data.ByteString.Lazy as B 12 | import System.Locale (defaultTimeLocale) 13 | 14 | import Data.Map (Map,keys) 15 | import qualified Data.Map as Map 16 | import Data.List (nub) 17 | 18 | import FloydWarshall 19 | 20 | data Currency = AUD | GBP | USD | CAD | CHF | JPY | EUR | DKK 21 | | NOK | NZD | SEK | SGD | HKD | XAU | XAG 22 | deriving (Read,Show,Ord,Ix,Eq,Enum) 23 | 24 | type CurrencyPair = (Currency,Currency) 25 | 26 | data ForexEntry = ForexEntry { 27 | lTid :: Int 28 | , currencyPair :: CurrencyPair 29 | , rateDateTime :: UTCTime 30 | , rateBid :: Double -- Price to the buyer 31 | , rateAsk :: Double -- Price to the seller 32 | } deriving Show 33 | 34 | forexHistory :: GenParser Char st [ForexEntry] 35 | forexHistory = header >> eol >> endBy entry eol 36 | 37 | header :: GenParser Char st [String] 38 | header = sepBy cell (char ',') 39 | 40 | eol :: GenParser Char st Char 41 | eol = char '\n' 42 | 43 | cell :: GenParser Char st String 44 | cell = many (noneOf ",\n") 45 | 46 | currencyPairParse :: GenParser Char st CurrencyPair 47 | currencyPairParse = liftM2 (,) currencyParse (char '/' >> currencyParse) 48 | 49 | currencyParse :: GenParser Char st Currency 50 | currencyParse = liftM read (many (noneOf "/,\n")) 51 | 52 | entry :: GenParser Char st ForexEntry 53 | entry = liftM5 ForexEntry parseInt 54 | (string ",D," >> currencyPairParse) 55 | (char ',' >> timeParser) 56 | (char ',' >> parseDouble) 57 | (char ',' >> parseDouble) 58 | 59 | parseInt :: GenParser Char st Int 60 | parseInt = liftM read cell 61 | 62 | parseDouble :: GenParser Char st Double 63 | parseDouble = liftM readDouble cell 64 | 65 | readDouble :: String -> Double 66 | readDouble s = read x 67 | where 68 | x | head s == '.' = '0':s 69 | | otherwise = s 70 | 71 | timeParser :: GenParser Char st UTCTime 72 | timeParser = liftM readTime (many (noneOf ",")) 73 | 74 | readTime :: String -> UTCTime 75 | readTime s | x == Nothing = error ("Undefined date format for " ++ s) 76 | | otherwise = fromJust x 77 | where 78 | x = parseTime defaultTimeLocale "%F %T" s 79 | 80 | parseFile :: FilePath -> IO [ForexEntry] 81 | parseFile s = do 82 | putStrLn $ "Reading " ++ s 83 | c <- B.readFile s 84 | case (parse forexHistory "Failed" c) of 85 | Left _ -> error "Failed to parse" 86 | Right q -> return q 87 | 88 | type ExchangePair = (Currency,Currency) 89 | type ExchangeData = Map ExchangePair Double 90 | data Exchange = Exchange ExchangeData 91 | 92 | instance Graph Exchange Currency where 93 | vertices = vertices' 94 | edge = edge' 95 | fromInt = fromInt' 96 | 97 | instance Show Exchange where 98 | show (Exchange s) = show s 99 | 100 | vertices' :: Exchange -> [Currency] 101 | vertices' (Exchange d) = nub $ map snd (keys d) 102 | 103 | edge' :: Exchange -> Currency -> Currency -> Maybe Double 104 | edge' (Exchange d) x y = Map.lookup (x,y) d 105 | 106 | fromInt' :: Exchange -> Int -> Currency 107 | fromInt' _ = toEnum 108 | 109 | update :: Exchange -> ForexEntry -> Exchange 110 | update (Exchange m) f = Exchange (Map.insert (b,a) sell 111 | (Map.insert (a,b) (1 / buy) m)) 112 | where 113 | (a,b) = currencyPair f 114 | buy = rateBid f 115 | sell = rateAsk f 116 | 117 | parseRecs :: [ForexEntry] -> [(Maybe [Currency], Exchange)] 118 | parseRecs recs = v 119 | where 120 | exchanges = scanl update (Exchange Map.empty) recs 121 | opportunities = zip (map findArbitrage exchanges) exchanges 122 | v = filter (\(x,y) -> x /= Nothing) opportunities 123 | 124 | main = do 125 | recs <- parseFile "/home/jeff/workspace/Haskell/haskellprojects/arbitrage/data/small_sorted_set.csv" 126 | print (take 10 $ parseRecs recs) 127 | {- 128 | 129 | Arbitrage is the practice of taking advantage of a price difference between two or more markets, striking a combination of matching deals that capitalize upon the imbalance, the profit being the difference between the market prices. 130 | 131 | TODO word better, check matches - see http://en.wikipedia.org/wiki/Fixed-odds_betting 132 | A simple example is a tennis match between two evenly matched players. One bookie might offer odds of 11/10 for one player, and another 11/10 for the other player. Putting $10 on each player means that you're guaranteed to win one bet and thus come out on top ($20 down, winning will yield you $22 yielding a profit of $2). 133 | 134 | Arbitrage situations shouldn't exist in an efficient market, but the arbitrage paradox (Grossman and Stiglitz) says that if arbitrage is never observed, market participants may not have sufficient incentives to watch the market, in which case arbitrage opportunities could arise. One resolution to this paradox is that opportunities do exist, though they are very short lived. 135 | 136 | -} 137 | 138 | 139 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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) -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /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 -------------------------------------------------------------------------------- /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 | })(); -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /ants/Ants.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | module Ants where 3 | 4 | import Control.Monad 5 | import Control.Concurrent.STM 6 | 7 | import Data.Ord (comparing) 8 | import Data.Maybe 9 | import Data.Vector (Vector) 10 | import qualified Data.Vector as V 11 | import Data.List (sortBy) 12 | import Data.Map (Map,unionWith) 13 | import qualified Data.Map as M 14 | 15 | import System.Random 16 | 17 | --import Criterion 18 | --import Criterion.Main 19 | 20 | -- |Dimensions of square world 21 | dim :: Int 22 | dim = 80 23 | 24 | -- |Number of ants 25 | nantsSqrt :: Int 26 | nantsSqrt = 10 27 | 28 | -- |Number of places with food 29 | foodPlaces :: Int 30 | foodPlaces = 100 31 | 32 | -- |Range of amount of food at a place 33 | foodRange :: Int 34 | foodRange = 100 35 | 36 | -- |Evaporation rate 37 | evapRate :: Double 38 | evapRate = 0.9999 39 | 40 | homeOff :: Int 41 | homeOff = dim `div` 4 42 | 43 | type TCell = TVar Cell 44 | 45 | type TCellArray = Vector TCell 46 | 47 | type World = TCellArray 48 | 49 | data Ant = Ant { 50 | direction :: !Direction 51 | , hasFood :: !Bool 52 | } deriving (Eq,Show) 53 | 54 | data Cell = Cell { 55 | food :: !Int 56 | , pher :: !Double 57 | , ant :: !(Maybe Ant) 58 | , home :: !Bool 59 | } deriving (Eq,Show) 60 | 61 | instance Ord Cell where 62 | compare = comparing food 63 | 64 | data Direction = N | NE | E | SE | S | SW | W | NW 65 | deriving (Enum,Show,Eq) 66 | 67 | turnRight :: Direction -> Direction 68 | turnRight NW = N 69 | turnRight x = succ x 70 | 71 | turnLeft :: Direction -> Direction 72 | turnLeft N = NW 73 | turnLeft x = pred x 74 | 75 | turnInt :: Int -> Direction -> Direction 76 | turnInt 0 d = d 77 | turnInt x d | x < 0 = turnInt (x + 1) (turnRight d) 78 | | otherwise = turnInt (x - 1) (turnLeft d) 79 | 80 | {- Boring helper functions -} 81 | hasAnt :: Cell -> Bool 82 | hasAnt (Cell _ _ (Just _) _) = True 83 | hasAnt _ = False 84 | 85 | homeRange :: [Int] 86 | homeRange = [homeOff..(nantsSqrt + homeOff)] 87 | 88 | delta :: Direction -> (Int,Int) 89 | delta N = (0,-1) 90 | delta NE = (1,-1) 91 | delta E = (1,0) 92 | delta SE = (1,1) 93 | delta S = (0,1) 94 | delta SW = (-1,1) 95 | delta W = (-1,0) 96 | delta NW = (-1,-1) 97 | 98 | -- |One step in the given direction, bounded by the dimension 99 | deltaLoc :: (Int,Int) -> Direction -> (Int,Int) 100 | deltaLoc (x,y) dir = (bound dim (x + dx), bound dim (y + dy)) 101 | where 102 | (dx,dy) = delta dir 103 | 104 | -- |Returns n wrapped into range 0-b 105 | bound :: Int -> Int -> Int 106 | bound b n | n' < 0 = n' + b 107 | | otherwise = n' 108 | where 109 | n' = rem n b 110 | 111 | wrand :: [Int] -> StdGen -> Int 112 | wrand xs gen = f 0 0 113 | where 114 | total = sum xs 115 | (r,_) = randomR (0,total - 1) gen 116 | f = \i sum -> if r < (xs !! i) + sum 117 | then i 118 | else f (succ i) (sum + (xs !! i)) 119 | 120 | -- |Causes all the phers to evaporate a bit 121 | -- The reason that this is done in the IO monad is that I want to apply lots of little updates 122 | -- and get them commited to the transaction. 123 | -- If I don't do this and run within the IO monad, then it's only commited when nothing else 124 | -- causes it to retry. 125 | evaporate :: World -> IO () 126 | evaporate w = V.forM_ w (\x -> atomically $ updateTVar x (\c -> c { pher = pher c * evapRate })) 127 | 128 | updateTVar :: TVar a -> (a -> a) -> STM () 129 | updateTVar !tv f = do 130 | x <- readTVar tv 131 | writeTVar tv $! (f x) 132 | 133 | place :: World -> (Int,Int) -> TCell 134 | place world (x,y) = world V.! (x*dim + y) 135 | 136 | -- |Must be called in a transaction where has food at loc 137 | takeFood :: World -> (Int,Int) -> STM () 138 | takeFood w loc = adjustFood w loc True 139 | 140 | -- |Must be called in a transaction where the ant has food 141 | dropFood :: World -> (Int,Int) -> STM () 142 | dropFood w loc = adjustFood w loc False 143 | 144 | adjustFood :: World -> (Int,Int) -> Bool -> STM () 145 | adjustFood w loc b = do 146 | let p = place w loc 147 | fv = if b then 1 else (- 1) 148 | updateTVar p (\c -> c { food = food c + fv 149 | , ant = Just ((fromJust (ant c)) { hasFood = b }) }) 150 | 151 | -- |Move the ant in the direction it is heading 152 | move :: World -> (Int,Int) -> STM (Int,Int) 153 | move w loc = do 154 | let src = place w loc 155 | cell <- readTVar src 156 | let dir = direction $ fromJust $ ant cell 157 | newLoc = deltaLoc loc dir 158 | 159 | -- Is the coast clear? 160 | dest <- readTVar (place w newLoc) 161 | check (not (hasAnt dest)) 162 | 163 | -- move the ant to the new cell 164 | updateTVar src (\x -> x { ant = Nothing } ) 165 | updateTVar (place w newLoc) (\x -> x { ant = ant cell }) 166 | 167 | -- Leave a trail 168 | unless (home cell) 169 | (updateTVar src (\x -> x { pher = succ $ pher x } )) 170 | return newLoc 171 | 172 | -- |Must be called when asserted there is an ant 173 | turnAnt :: Int -> Cell -> Cell 174 | turnAnt amt cell = cell { ant = Just turnedAnt } 175 | where 176 | a = fromJust $ ant cell 177 | turnedAnt = a { direction = turnInt amt (direction a) } 178 | 179 | -- |Must be called when true that world (int,int) is an ant 180 | turn :: World -> (Int,Int) -> Int -> STM () 181 | turn w loc amt = do 182 | let src = place w loc 183 | cell <- readTVar src 184 | updateTVar src (turnAnt amt) 185 | 186 | -- | Map to their 1-based rank 187 | rankBy :: (Cell -> Cell -> Ordering) -> [Cell] -> Map Cell Int 188 | rankBy f xs = foldl (\m i -> M.insert (sorted !! i) (succ i) m) M.empty [0..length sorted - 1] 189 | where 190 | sorted = sortBy f xs 191 | 192 | -- | The main function for the ant agent 193 | behave :: StdGen -> World -> (Int,Int) -> STM (Int,Int) 194 | behave gen w loc = do 195 | cell <- readTVar (place w loc) 196 | let a = fromJust $ ant cell 197 | ahead <- readTVar $ place w (deltaLoc loc (direction a)) 198 | aheadLeft <- readTVar $ place w (deltaLoc loc (turnLeft (direction a))) 199 | aheadRight <- readTVar $ place w (deltaLoc loc (turnRight(direction a))) 200 | let places = [ahead,aheadLeft,aheadRight] 201 | p = rankBy (comparing pher) places 202 | f = rankBy (comparing food) places 203 | h = rankBy (comparing home) places 204 | ranks = if hasFood a then unionWith (+) p h else unionWith (+) f p 205 | choice = wrand [if hasAnt ahead then 0 else ranks M.! ahead 206 | ,ranks M.! aheadLeft 207 | ,ranks M.! aheadRight] gen 208 | action = [move w 209 | ,\x -> turn w x 1 >> return x 210 | ,\x -> turn w x (- 1) >> return x] !! choice 211 | if hasFood a 212 | then if home cell 213 | then dropFood w loc >> turn w loc 4 >> return loc -- drop food, turn around 214 | else if home ahead && not (hasAnt ahead) 215 | then move w loc -- head forward knowing the way is clear 216 | else action loc 217 | else if food cell > 0 && not (home cell) -- if there is food and we aren't at home 218 | then takeFood w loc >> turn w loc 4 >> return loc 219 | else if (food ahead > 0) && not (home ahead) && not (hasAnt ahead) -- food ahead and nothing in the way 220 | then move w loc 221 | else action loc 222 | 223 | 224 | mkCell :: Int -> Double -> Cell 225 | mkCell f p = Cell f p Nothing False 226 | 227 | mkWorld :: IO (World,[(Int,Int)]) 228 | mkWorld = do 229 | gen <- getStdGen 230 | 231 | w <- atomically $ do 232 | cs <- replicateM ((1+dim)*(1+dim)) (newTVar (mkCell 0 0)) 233 | return (V.fromList cs) 234 | 235 | let dims = take (2*foodPlaces) $ randomRs (0,dim) gen :: [Int] 236 | dirs = randomRs (0,7) gen :: [Int] 237 | foodRanges = randomRs (0,foodRange) gen :: [Int] 238 | xy = uncurry zip $ splitAt foodPlaces dims 239 | 240 | -- Position the food randomly 241 | forM_ (zip3 [0..foodPlaces] xy foodRanges) 242 | (\(_,p,f) -> atomically $ updateTVar (place w p) (\x -> x{ food = f })) 243 | 244 | -- Set up the home area 245 | ants <- forM (zip [(x,y) | x <- homeRange, y <- homeRange] dirs) 246 | (\(p,dir) -> atomically $ updateTVar (place w p) 247 | (\x -> x { home = True, ant = Just (Ant (toEnum dir) False) }) >> return p) 248 | 249 | return (w,ants) 250 | 251 | -- |Just for debugging 252 | countAnts :: World -> STM Int 253 | countAnts w = liftM V.length (V.filterM (\x -> fmap hasAnt (readTVar x)) w) 254 | 255 | getAnts :: World -> STM [Ant] 256 | getAnts w = liftM (catMaybes . V.toList) $ V.mapM (\x -> fmap ant (readTVar x)) w 257 | 258 | -- Performance benchmarks 259 | {-main = do 260 | (world,(ant:ants)) <- mkWorld 261 | let gen = mkStdGen 101 262 | defaultMain [ 263 | bgroup "Ants" [ bench "evaporate" $ whnfIO $ atomically $ evaporate world ] 264 | ]-} 265 | -- , bench "behave" $ whnfIO $ atomically $ behave gen world ant] 266 | 267 | -------------------------------------------------------------------------------- /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 | -------------------------------------------------------------------------------- /6502/Em6502.hs: -------------------------------------------------------------------------------- 1 | -- {-# LANGUAGE BangPatterns #-} 2 | module Em6502 where 3 | 4 | -- TODO use cabal! 5 | 6 | -- ghci -hide-package monads-fd-0.1.0.1 -Wall Em6502.hs 7 | 8 | -- Lots of useful infomration from 9 | -- http://e-tradition.net/bytes/6502/6502cpu.js 10 | 11 | import Data.Array 12 | import Data.IORef 13 | import Data.Int (Int8) 14 | import Data.Word (Word8,Word16) 15 | import Data.Bits 16 | import qualified Data.Vector.Unboxed.Mutable as M 17 | import qualified Data.Vector.Generic.Mutable as GM 18 | 19 | import Control.Monad 20 | 21 | -- I'm pretty sure that I want to express this better in a state monad 22 | -- import Control.Monad.ST 23 | -- import Control.Monad.State 24 | 25 | import Prelude hiding (break) 26 | 27 | type Byte = Word8 28 | type SByte = Int8 29 | type ByteVector = M.IOVector Byte 30 | 31 | -- http://www.obelisk.demon.co.uk/6502/registers.html 32 | data CPU = CPU { 33 | ram :: ByteVector 34 | , pc :: IORef Word16 -- ^ Program counter 35 | , yr :: IORef Byte -- ^ Y Register 36 | , xr :: IORef Byte -- ^ X Register 37 | , sr :: IORef Byte -- ^ Status Register 38 | , sp :: IORef Byte -- ^ Stack Pointer 39 | , ac :: IORef Byte -- ^ Accumulator 40 | , cycles :: IORef Int -- ^ Processor cycles 41 | } 42 | 43 | data Flag = Negative 44 | | Overflow 45 | | Ignored 46 | | Break 47 | | Decimal 48 | | Interrupt 49 | | Zero 50 | | Carry 51 | 52 | -- http://www.obelisk.demon.co.uk/6502/addressing.html explains addressing modes 53 | data AddressMode = Accumulator 54 | | Immediate Byte 55 | | ZeroPage Byte 56 | | ZeroPageX Byte 57 | | ZeroPageY Byte 58 | | Relative Int 59 | | Absolute Word16 60 | | AbsoluteX Word16 61 | | AbsoluteY Word16 62 | | Indirect Word16 63 | | IndirectX Byte 64 | | IndirectY Byte 65 | deriving (Show) 66 | 67 | data Instruction = ADC AddressMode -- ^ ADd with Carry 68 | | AND AddressMode -- ^ AND (with accumulator) 69 | | ASL AddressMode -- ^ Arithmetic Shift Left 70 | | BCC SByte -- ^ Branch on Carry Clear 71 | | BCS SByte -- ^ Branch on Carry Set 72 | | BEQ SByte -- ^ Branch on EQual (zero set) 73 | | BIT AddressMode -- ^ BIT test 74 | | BMI SByte -- ^ Branch on MInus (negative set) 75 | | BNE SByte -- ^ Branch on Not Equal (zero clear) 76 | | BPL SByte -- ^ Branch on PLus (negative clear) 77 | | BRK -- ^ BReaK (interrupt) 78 | | BVC SByte -- ^ Branch on oVerflow Clear 79 | | BVS SByte -- ^ Branch on oVerflow Set 80 | | CLC -- ^ CLear Carry 81 | | CLD -- ^ CLear Decimal 82 | | CLI -- ^ CLear Interrupt disable 83 | | CLV -- ^ CLear oVerflow 84 | | CMP AddressMode -- ^ CoMPare (with accumulator) 85 | | CPX AddressMode -- ^ ComPare with X 86 | | CPY AddressMode -- ^ ComPare with Y 87 | | DEC AddressMode -- ^ DECrement 88 | | DEX -- ^ DEcrement X 89 | | DEY -- ^ DEcrement Y 90 | | EOR AddressMode -- ^ Exclusive OR (with accumulator) 91 | | INC AddressMode -- ^ INCrement 92 | | INX -- ^ INcrement X 93 | | INY -- ^ INcrement Y 94 | | JMP AddressMode -- ^ JuMP 95 | | JSR AddressMode -- ^ Jump SubRoutine 96 | | LDA AddressMode -- ^ LoaD Accumulator 97 | | LDX AddressMode -- ^ LoaD X 98 | | LDY AddressMode -- ^ LoaD Y 99 | | LSR AddressMode -- ^ Logical Shift Right 100 | | NOP -- ^ No OPeration 101 | | ORA AddressMode -- ^ OR with Accumulator 102 | | PHA -- ^ PusH Accumulator 103 | | PHP -- ^ PusH Processor status (SR) 104 | | PLA -- ^ PulL Accumulator 105 | | PLP -- ^ PulL Processor status (SR) 106 | | ROL AddressMode -- ^ ROtate Left 107 | | ROR AddressMode -- ^ ROtate Right 108 | | RTI -- ^ ReTurn from Interrupt 109 | | RTS -- ^ ReTurn from Subroutine 110 | | SBC AddressMode -- ^ SuBtract with Carry 111 | | SEC -- ^ SEt Carry 112 | | SED -- ^ SEt Decimal 113 | | SEI -- ^ SEt Interrupt disable 114 | | STA AddressMode -- ^ STore Accumulator 115 | | STX AddressMode -- ^ STore X 116 | | STY AddressMode -- ^ STore Y 117 | | TAX -- ^ Transfer Accumulator to X 118 | | TAY -- ^ Transfer Accumulator to Y 119 | | TSX -- ^ Transfer Stack pointer to X 120 | | TXA -- ^ Transfer X to Accumulator 121 | | TXS -- ^ Transfer X to Stack pointer 122 | | TYA -- ^ Transfer Y to Accumulator 123 | deriving (Show) 124 | 125 | -- |The maximum amount of RAM addressable by a 6502 126 | maxAddress :: Word16 127 | maxAddress = maxBound 128 | 129 | flag :: Flag -> Word8 130 | flag Negative = 8 131 | flag Overflow = 7 132 | flag Ignored = 6 133 | flag Break = 5 134 | flag Decimal = 4 135 | flag Interrupt = 3 136 | flag Zero = 2 137 | flag Carry = 1 138 | 139 | setFlagValue :: CPU -> Flag -> Bool -> IO () 140 | setFlagValue c f True = setFlag c f 141 | setFlagValue c f False = clearFlag c f 142 | 143 | setFlag :: CPU -> Flag -> IO () 144 | setFlag c f = modifyIORef (sr c) (`setBit` fromIntegral (flag f)) 145 | 146 | setFlags :: CPU -> [Flag] -> IO () 147 | setFlags c = mapM_ (setFlag c) 148 | 149 | clearFlag :: CPU -> Flag -> IO () 150 | clearFlag c f = modifyIORef (sr c) (`clearBit` fromIntegral (flag f)) 151 | 152 | clearFlags :: CPU -> [Flag] -> IO () 153 | clearFlags c = mapM_ (clearFlag c) 154 | 155 | isSet :: CPU -> Flag -> IO Bool 156 | isSet cpu f = do 157 | sr' <- readIORef (sr cpu) 158 | return (testBit sr' (fromIntegral $ flag f)) 159 | 160 | incPC :: CPU -> Word16 -> IO () 161 | incPC c i = modifyIORef (pc c) (+ i) 162 | 163 | stepPC :: CPU -> IO () 164 | stepPC c = incPC c 1 165 | 166 | step2PC :: CPU -> IO () 167 | step2PC c = incPC c 2 168 | 169 | toByte :: Word16 -> Byte 170 | toByte w = fromIntegral (255 .&. w) 171 | 172 | readByte :: CPU -> Word16 -> IO Byte 173 | readByte cpu addr = GM.read (ram cpu) (fromIntegral addr) 174 | 175 | readWord :: CPU -> Word16 -> IO Word16 176 | readWord cpu addr = do 177 | byte1 <- readByte cpu addr 178 | byte2 <- readByte cpu (0xFFFF .&. (addr + 1)) 179 | return $ fromIntegral byte1 + (fromIntegral byte2 * 256) 180 | 181 | writeByte :: CPU -> Word16 -> Byte -> IO () 182 | writeByte cpu addr = GM.write (ram cpu) (fromIntegral addr) 183 | 184 | currentByte :: CPU -> IO Byte 185 | currentByte cpu = do 186 | p <- readIORef (pc cpu) 187 | readByte cpu p 188 | 189 | stackPushByte :: CPU -> Byte -> IO () 190 | stackPushByte cpu val = do 191 | sp' <- readIORef (sp cpu) 192 | writeByte cpu (fromIntegral sp' + 256) val 193 | modifyIORef (sp cpu) (flip (-) 1) 194 | 195 | stackPopByte :: CPU -> IO Byte 196 | stackPopByte cpu = do 197 | s <- readIORef (sp cpu) 198 | val <- readByte cpu (fromIntegral s+256) 199 | modifyIORef (sp cpu) (+ 1) 200 | return val 201 | 202 | stackPushWord :: CPU -> Word16 -> IO () 203 | stackPushWord cpu x = do 204 | stackPushByte cpu (fromIntegral (x `shiftR` 8) .&. 0xFF) 205 | stackPushByte cpu (fromIntegral x .&. 0xFF) 206 | 207 | stackPopWord :: CPU -> IO Word16 208 | stackPopWord cpu = do 209 | byte1 <- stackPopByte cpu 210 | byte2 <- stackPopByte cpu 211 | return $ (fromIntegral byte1 :: Word16) + (256 * fromIntegral byte2 :: Word16) 212 | 213 | zeroPageAddr :: CPU -> IO Word16 214 | zeroPageAddr cpu = do 215 | pc' <- readIORef (pc cpu) 216 | liftM fromIntegral $ readByte cpu pc' 217 | 218 | zeroPageXAddr :: CPU -> IO Word16 219 | zeroPageXAddr cpu = do 220 | pc' <- readIORef (pc cpu) 221 | b <- readByte cpu pc' 222 | xr' <- readIORef (xr cpu) 223 | return $ fromIntegral (xr' + b) 224 | 225 | zeroPageYAddr :: CPU -> IO Word16 226 | zeroPageYAddr cpu = do 227 | pc' <- readIORef (pc cpu) 228 | b <- readByte cpu pc' 229 | yr' <- readIORef (yr cpu) 230 | return $ fromIntegral (yr' + b) 231 | 232 | indirectXAddr :: CPU -> IO Word16 233 | indirectXAddr cpu = do 234 | pc' <- readIORef (pc cpu) 235 | b <- readByte cpu pc' 236 | xr' <- readIORef (xr cpu) 237 | readWord cpu (255 .&. (fromIntegral b + fromIntegral xr')) 238 | 239 | indirectYAddr :: CPU -> IO Word16 240 | indirectYAddr cpu = do 241 | pc' <- readIORef (pc cpu) 242 | b <- readByte cpu pc' 243 | yr' <- readIORef (yr cpu) 244 | readWord cpu ((fromIntegral b + fromIntegral yr') .&. 0xFFFF) 245 | 246 | absoluteAddr :: CPU -> IO Word16 247 | absoluteAddr cpu = do 248 | pc' <- readIORef (pc cpu) 249 | readWord cpu pc' 250 | 251 | absoluteXAddr :: CPU -> IO Word16 252 | absoluteXAddr cpu = do 253 | pc' <-readIORef (pc cpu) 254 | w <- readWord cpu pc' 255 | xr' <- readIORef (xr cpu) 256 | return (w + fromIntegral xr' .&. 0xFFFF) 257 | 258 | absoluteYAddr :: CPU -> IO Word16 259 | absoluteYAddr cpu = do 260 | pc' <- readIORef (pc cpu) 261 | w <- readWord cpu pc' 262 | yr' <- readIORef (yr cpu) 263 | return (w + fromIntegral yr' .&. 0xFFFF) 264 | 265 | branchRelAddr :: CPU -> IO () 266 | branchRelAddr cpu = do 267 | address <- currentByte cpu 268 | pc' <- readIORef (pc cpu) 269 | let pcOff = if testBit addr 7 then -(1 + (address `xor` 255)) else address 270 | addr = pc' + fromIntegral pcOff 271 | writeIORef (pc cpu) (addr .&. 0xFFFF) 272 | 273 | readWord8 :: CPU -> AddressMode -> IO Word8 274 | readWord8 cpu Accumulator = readIORef (ac cpu) 275 | readWord8 cpu (Immediate byte) = return $ fromIntegral byte 276 | readWord8 cpu (ZeroPage byte) = (readByte cpu (fromIntegral byte)) 277 | readWord8 cpu (ZeroPageX byte) = do 278 | x <- readIORef (xr cpu) 279 | readByte cpu (fromIntegral byte + fromIntegral x) 280 | readWord8 cpu (ZeroPageY byte) = do 281 | y <- readIORef (yr cpu) 282 | readByte cpu (fromIntegral $ byte + y) 283 | readWord8 cpu (Relative int) = error "Relative is to adjust the PC" 284 | readWord8 cpu (Absolute word16) = liftM fromIntegral (readByte cpu word16) 285 | readWord8 cpu (AbsoluteX word16) = undefined 286 | readWord8 cpu (AbsoluteY word16) = undefined 287 | readWord8 cpu (Indirect word16) = undefined 288 | readWord8 cpu (IndirectX byte) = undefined 289 | readWord8 cpu (IndirectY byte) = undefined 290 | 291 | writeWord16 :: CPU -> AddressMode -> Word16 -> IO () 292 | writeWord16 cpu Accumulator val = writeIORef (ac cpu) (fromIntegral (val .&. 255)) 293 | writeWord16 cpu (Immediate byte) val = error "Immediate only supports an 8 bit constant" 294 | writeWord16 cpu (ZeroPage byte) val = undefined 295 | writeWord16 cpu (ZeroPageX byte) val = undefined 296 | writeWord16 cpu (ZeroPageY byte) val = undefined 297 | writeWord16 cpu (Relative int) val = error "Relative is to adjust the PC" 298 | writeWord16 cpu (Absolute word16) val = undefined 299 | writeWord16 cpu (AbsoluteX word16) val = undefined 300 | writeWord16 cpu (AbsoluteY word16) val = undefined 301 | writeWord16 cpu (Indirect word16) val = undefined 302 | writeWord16 cpu (IndirectX byte) val = undefined 303 | writeWord16 cpu (IndirectY byte) val = undefined 304 | 305 | writeWord8 :: CPU -> AddressMode -> Word8 -> IO () 306 | writeWord8 cpu Accumulator val = writeIORef (ac cpu) val 307 | writeWord8 cpu (Immediate byte) val = undefined 308 | writeWord8 cpu (ZeroPage byte) val = undefined 309 | writeWord8 cpu (ZeroPageX byte) val = undefined 310 | writeWord8 cpu (ZeroPageY byte) val = undefined 311 | writeWord8 cpu (Relative int) val = undefined 312 | writeWord8 cpu (Absolute word8) val = writeByte cpu word8 val 313 | writeWord8 cpu (AbsoluteX word8) val = undefined 314 | writeWord8 cpu (AbsoluteY word8) val = undefined 315 | writeWord8 cpu (Indirect word8) val = undefined 316 | writeWord8 cpu (IndirectX byte) val = undefined 317 | writeWord8 cpu (IndirectY byte) val = undefined 318 | 319 | -- |Create a brand new CPU initialized appropriately 320 | mkCPU :: IO CPU 321 | mkCPU = do 322 | mem <- GM.newWith (fromIntegral (maxBound :: Word16)) 0 323 | pc' <- newIORef 0 324 | yr' <- newIORef 0 325 | xr' <- newIORef 0 326 | sr' <- newIORef $ flag Ignored 327 | sp' <- newIORef 255 328 | ac' <- newIORef 0 329 | cycles' <- newIORef 0 330 | break' <- newIORef False 331 | return CPU { 332 | ram = mem 333 | , pc = pc' 334 | , yr = yr' 335 | , xr = xr' 336 | , sr = sr' 337 | , sp = sp' 338 | , ac = ac' 339 | , cycles = cycles' 340 | } 341 | 342 | execute :: CPU -> Instruction -> IO () 343 | execute cpu (ADC addressMode) = adcOp cpu addressMode 344 | execute cpu (AND addressMode) = bitWiseOp cpu addressMode (.&.) 345 | execute cpu (ASL addressMode) = shiftLeft cpu addressMode 346 | execute cpu (BCC addressMode) = branchIf cpu Carry False 347 | execute cpu (BCS addressMode) = branchIf cpu Carry True 348 | execute cpu (BEQ addressMode) = branchIf cpu Zero True 349 | execute cpu (BIT addressMode) = bitTest cpu addressMode 350 | execute cpu (BMI addressMode) = branchIf cpu Negative True 351 | execute cpu (BNE addressMode) = branchIf cpu Zero False 352 | execute cpu (BPL addressMode) = branchIf cpu Negative False 353 | execute cpu BRK = undefined 354 | execute cpu (BVC addressMode) = branchIf cpu Overflow False 355 | execute cpu (BVS addressMode) = branchIf cpu Overflow True 356 | execute cpu CLC = clearFlag cpu Carry 357 | execute cpu CLD = clearFlag cpu Decimal 358 | execute cpu CLI = clearFlag cpu Interrupt 359 | execute cpu CLV = clearFlag cpu Overflow 360 | execute cpu (CMP addressMode) = comp cpu addressMode (ac cpu) 361 | execute cpu (CPX addressMode) = comp cpu addressMode (xr cpu) 362 | execute cpu (CPY addressMode) = comp cpu addressMode (yr cpu) 363 | execute cpu (DEC addressMode) = undefined 364 | execute cpu DEX = undefined 365 | execute cpu DEY = undefined 366 | execute cpu (EOR addressMode) = bitWiseOp cpu addressMode xor 367 | execute cpu (INC addressMode) = undefined 368 | execute cpu INX = undefined 369 | execute cpu INY = undefined 370 | execute cpu (JMP addressMode) = undefined 371 | execute cpu (JSR addressMode) = undefined 372 | execute cpu (LDA addressMode) = load cpu (ac cpu) addressMode 373 | execute cpu (LDX addressMode) = load cpu (xr cpu) addressMode 374 | execute cpu (LDY addressMode) = load cpu (yr cpu) addressMode 375 | execute cpu (LSR addressMode) = undefined 376 | execute cpu NOP = undefined 377 | execute cpu (ORA addressMode) = bitWiseOp cpu addressMode (.|.) 378 | execute cpu PHA = pushRef cpu (ac cpu) 379 | execute cpu PHP = pushRef cpu (sr cpu) 380 | execute cpu PLA = pullRef cpu (ac cpu) True 381 | execute cpu PLP = pullRef cpu (sr cpu) False 382 | execute cpu (ROL addressMode) = undefined 383 | execute cpu (ROR addressMode) = undefined 384 | execute cpu RTI = undefined 385 | execute cpu RTS = undefined 386 | execute cpu (SBC addressMode) = sbcOp cpu addressMode 387 | execute cpu SEC = setFlag cpu Carry 388 | execute cpu SED = setFlag cpu Decimal 389 | execute cpu SEI = setFlag cpu Interrupt 390 | execute cpu (STA addressMode) = store cpu (ac cpu) addressMode 391 | execute cpu (STX addressMode) = store cpu (xr cpu) addressMode 392 | execute cpu (STY addressMode) = store cpu (yr cpu) addressMode 393 | execute cpu TAX = transferToAccumulator cpu (xr cpu) 394 | execute cpu TAY = transferToAccumulator cpu (yr cpu) 395 | execute cpu TSX = copyRegister cpu (sp cpu) (xr cpu) True 396 | execute cpu TXA = copyRegister cpu (xr cpu) (ac cpu) True 397 | execute cpu TXS = copyRegister cpu (xr cpu) (sp cpu) False 398 | execute cpu TYA = copyRegister cpu (yr cpu) (ac cpu) True 399 | 400 | shiftLeft :: CPU -> AddressMode -> IO () 401 | shiftLeft cpu address = do 402 | byte <- readWord8 cpu address 403 | clearFlags cpu [Carry,Negative,Zero] 404 | when (testBit (byte .&. 255) 7) (setFlag cpu Carry) 405 | let shf = shiftL (fromIntegral byte) 1 406 | if shf == 0 407 | then setFlag cpu Zero 408 | else setFlagValue cpu Overflow (testBit (byte .&. 255) 7) 409 | writeWord16 cpu address shf 410 | 411 | adcOp :: CPU -> AddressMode -> IO () 412 | adcOp cpu address = do 413 | status <- readIORef (sr cpu) 414 | byte <- readWord8 cpu address 415 | acc <- readIORef (ac cpu) 416 | isDecimalMode <- isSet cpu Decimal 417 | isCarry <- isSet cpu Carry 418 | let carry = if isCarry then 0 else 1 419 | if isDecimalMode 420 | then do 421 | let d = bcd2dec ! fromIntegral acc + bcd2dec ! fromIntegral byte + carry 422 | clearFlags cpu [Carry,Zero,Negative,Overflow] 423 | when (d>99) (setFlags cpu [Overflow,Carry]) 424 | when (d==0) (setFlag cpu Zero) 425 | when (d <0) (setFlagValue cpu Zero $ testBit (d .&. 255) (fromIntegral $ flag Zero)) 426 | writeIORef (ac cpu) ((fromIntegral d .&. 255) - if d > 99 then 100 else 0) 427 | else do 428 | let d = fromIntegral acc + byte + if isCarry then 1 else 0 429 | when (d > 255) (setFlags cpu [Carry,Overflow]) 430 | when (d == 0 ) (setFlag cpu Zero) 431 | setFlagValue cpu Overflow $ testBit (d .&. 255) (fromIntegral $ flag Overflow) 432 | writeIORef (ac cpu) (fromIntegral d .&. 255) 433 | 434 | sbcOp :: CPU -> AddressMode -> IO () 435 | sbcOp cpu address = do 436 | status <- readIORef (sr cpu) 437 | byte <- readWord8 cpu address 438 | acc <- readIORef (ac cpu) 439 | isDecimalMode <- isSet cpu Decimal 440 | isCarry <- isSet cpu Carry 441 | let carry = if isCarry then 0 else 1 442 | if isDecimalMode 443 | then do 444 | let d = bcd2dec ! fromIntegral acc - bcd2dec ! fromIntegral byte - carry 445 | clearFlags cpu [Carry,Zero,Negative,Overflow] 446 | when (d==0) (setFlags cpu [Zero,Carry]) 447 | when (d >0) (setFlag cpu Carry) 448 | when (d <0) (setFlag cpu Negative) 449 | writeIORef (ac cpu) ((fromIntegral d .&. 255) + if d < 0 then 100 else 0) 450 | else do 451 | let d = fromIntegral acc - byte - fromIntegral carry 452 | clearFlags cpu [Carry,Zero,Negative,Overflow] 453 | when (d==0) (setFlags cpu [Zero,Carry]) 454 | when (d >0) (setFlag cpu Carry) 455 | when (d <0) (setFlag cpu Overflow) 456 | setFlagValue cpu Overflow $ testBit (d .&. 255) (fromIntegral $ flag Overflow) 457 | writeIORef (ac cpu) (fromIntegral d .&. 255) 458 | 459 | bitTest :: CPU -> AddressMode -> IO () 460 | bitTest cpu address = do 461 | this <- readWord8 cpu address 462 | clearFlags cpu [Carry,Zero,Negative] 463 | ac' <- readIORef (ac cpu) 464 | let res = ac' .&. (fromIntegral this .&. 255) 465 | when (res == 0) $ setFlag cpu Zero 466 | setFlagValue cpu Overflow $ testBit res (fromIntegral $ flag Overflow) 467 | setFlagValue cpu Negative $ testBit res (fromIntegral $ flag Negative) 468 | 469 | comp :: CPU -> AddressMode -> IORef Byte -> IO () 470 | comp cpu address src = do 471 | that <- readWord8 cpu address 472 | this <- readIORef src 473 | clearFlags cpu [Carry,Zero,Negative] 474 | case (compare this (fromIntegral $ that .&. 255)) of 475 | EQ -> setFlags cpu [Carry,Zero] 476 | GT -> setFlag cpu Carry 477 | LT -> setFlag cpu Negative 478 | 479 | branchIf :: CPU -> Flag -> Bool -> IO () 480 | branchIf cpu fl val = do 481 | f <- isSet cpu fl 482 | if f == val then branchRelAddr cpu else stepPC cpu 483 | 484 | copyRegister :: CPU -> IORef Byte -> IORef Byte -> Bool -> IO () 485 | copyRegister cpu src dest updateFlags = do 486 | byte <- readIORef src 487 | writeIORef dest byte 488 | when updateFlags $ setZeroNegativeFlags cpu byte 489 | 490 | store :: CPU -> IORef Byte -> AddressMode -> IO () 491 | store cpu source address = do 492 | src <- readIORef source 493 | addr <- readWord8 cpu address 494 | writeWord8 cpu address src 495 | 496 | load :: CPU -> IORef Byte -> AddressMode -> IO () 497 | load cpu destination address = do 498 | addr <- readWord8 cpu address 499 | byte <- readByte cpu (fromIntegral addr) 500 | writeIORef destination byte 501 | setZeroNegativeFlags cpu byte 502 | 503 | bitWiseOp :: CPU -> AddressMode -> (Byte -> Byte -> Byte) -> IO () 504 | bitWiseOp cpu byte op = do 505 | b <- readWord8 cpu byte 506 | modifyIORef (ac cpu) (\x -> fromIntegral $ op (fromIntegral b) x) 507 | result <- readIORef (ac cpu) 508 | setZeroNegativeFlags cpu result 509 | 510 | pushRef :: CPU -> IORef Byte -> IO () 511 | pushRef cpu src = do 512 | val <- readIORef src 513 | stackPushByte cpu val 514 | 515 | pullRef :: CPU -> IORef Byte -> Bool -> IO () 516 | pullRef cpu src flagsToSet = do 517 | val <- stackPopByte cpu 518 | writeIORef src val 519 | when flagsToSet (setZeroNegativeFlags cpu val) 520 | 521 | transferToAccumulator :: CPU -> IORef Byte -> IO () 522 | transferToAccumulator cpu dest = do 523 | val <- readIORef dest 524 | writeIORef (ac cpu) val 525 | setZeroNegativeFlags cpu val 526 | 527 | setZeroNegativeFlags :: CPU -> Byte -> IO () 528 | setZeroNegativeFlags cpu b = do 529 | clearFlags cpu [Zero,Negative] 530 | if b == 0 then setFlag cpu Zero else when (testBit b 7) (setFlag cpu Negative) 531 | 532 | bcd2dec :: Array Byte Word16 533 | bcd2dec= listArray (0,255) [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 -- 0x00 534 | ,10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25 -- 0x10 535 | ,20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35 -- 0x20 536 | ,30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45 -- 0x30 537 | ,40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, 54, 55 -- 0x40 538 | ,50, 51, 52, 53, 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 65 -- 0x50 539 | ,60, 61, 62, 63, 64, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75 -- 0x60 540 | ,70, 71, 72, 73, 74, 75, 76, 77, 78, 79, 80, 81, 82, 83, 84, 85 -- 0x70 541 | ,80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 91, 92, 93, 94, 95 -- 0x80 542 | ,90, 91, 92, 93, 94, 95, 96, 97, 98, 99,100,101,102,103,104,105 -- 0x90 543 | ,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115 -- 0xA0 544 | ,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125 -- 0xB0 545 | ,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135 -- 0xC0 546 | ,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145 -- 0xD0 547 | ,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155 -- 0xE0 548 | ,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165]-- 0xF0 549 | 550 | dec2bcd :: Array Byte Byte 551 | dec2bcd = listArray (0,255) [0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09 552 | ,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19 553 | ,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28,0x29 554 | ,0x30,0x31,0x32,0x33,0x34,0x35,0x36,0x37,0x38,0x39 555 | ,0x40,0x41,0x42,0x43,0x44,0x45,0x46,0x47,0x48,0x49 556 | ,0x50,0x51,0x52,0x53,0x54,0x55,0x56,0x57,0x58,0x59 557 | ,0x60,0x61,0x62,0x63,0x64,0x65,0x66,0x67,0x68,0x69 558 | ,0x70,0x71,0x72,0x73,0x74,0x75,0x76,0x77,0x78,0x79 559 | ,0x80,0x81,0x82,0x83,0x84,0x85,0x86,0x87,0x88,0x89 560 | ,0x90,0x91,0x92,0x93,0x94,0x95,0x96,0x97,0x98,0x99] 561 | 562 | runInstructions :: CPU -> [Instruction] -> IO () 563 | runInstructions cpu instructions = forM_ instructions (execute cpu) --------------------------------------------------------------------------------