├── .gitignore
├── Algorithms.cabal
├── Data
├── Infinitable.hs
└── Tree
│ ├── Binary.hs
│ ├── RandomTreap.hs
│ └── Treap.hs
├── Haskell-Algorithms.cabal
├── LICENSE
├── Materials
├── Back to the Future - Tech Talks NSU
│ ├── Adapter.hs
│ ├── Adapter2.hs
│ └── Strategy.hs
├── Design and Architecture in FP
│ ├── ExistentialAntipattern.hs
│ ├── Goals-Simplicity-Requirements.svg
│ ├── GoodDesign-1.png
│ ├── GoodDesign-2-Problem1.png
│ ├── GoodDesign-2-Problem2.png
│ ├── GoodDesign-2-Problem3.png
│ ├── GoodDesign-2-Problem4.png
│ ├── GoodDesign-2.png
│ └── WorldCellAdt.hs
├── Game Development Materials.txt
├── Haskell в реальном мире - Статья
│ ├── Haskell в реальном мире.txt
│ ├── merger 0.13.hs
│ ├── merger 0.14.hs
│ ├── merger 0.16.hs
│ ├── merger 0.23.hs
│ ├── parser 0.12.hs
│ ├── parser 0.2.hs
│ └── parser 0.6.hs
└── YAMT
│ ├── Mike Vanier's monad tutorial part 1 - Translation.txt
│ ├── Mike Vanier's monad tutorial part 2 - Translation.txt
│ ├── Mike Vanier's monad tutorial part 3 - Translation.txt
│ ├── Mike Vanier's monad tutorial part 4 - Translation.txt
│ └── Mike Vanier's monad tutorial part 5 - Translation.txt
├── Programs
├── GameOfLifeComonad
│ ├── .gitignore
│ ├── GlossMetaLife.hs
│ ├── Life.hs
│ ├── MetaLife.hs
│ ├── SampleCells.hs
│ ├── Universe.hs
│ ├── config.txt
│ ├── run.cmd
│ └── run.sh
├── HabrFormat
│ ├── .gitignore
│ ├── HabrFormat.hs
│ ├── article.html
│ └── formated_article.html
├── NgnTraffic Old
│ ├── LICENSE.GPL3
│ ├── LicenseTemplate.txt
│ ├── merger.hs
│ └── parser.hs
├── NgnTraffic
│ ├── .gitignore
│ ├── Constants.hs
│ ├── DataProcess.hs
│ ├── FileListProcess.hs
│ ├── LICENSE.GPL3
│ ├── LicenseTemplate.txt
│ ├── NgnTraffic.hs
│ ├── Options.hs
│ ├── README
│ ├── Tools.hs
│ └── Types.hs
├── RestCorrecting
│ ├── DataProcess.hs
│ ├── LicenseTemplate.txt
│ ├── README
│ ├── RestCorrecting.hs
│ ├── Sql.hs
│ ├── TestData.hs
│ ├── Types.hs
│ ├── dbDataTest.txt
│ ├── id_obsh.txt
│ ├── testResult.txt
│ └── updateScripts.sql
└── SimpleFormat
│ ├── Process.hs
│ └── SimpleFormat.hs
├── Prototypes
├── Adv2Game
│ ├── Types.hs
│ └── Types2.hs
├── BigSpace.EventFlowTree
│ ├── Actions.hs
│ ├── Event.hs
│ ├── EventFlowTree.hs
│ ├── Main.hs
│ ├── PreGen
│ │ └── World.hs
│ ├── README
│ ├── Tools.hs
│ ├── Types.hs
│ └── test.txt
└── BigSpace.FingerTreeUnstructured
│ ├── BigSpace.hs
│ └── Type
│ ├── Constants.hs
│ ├── Event.hs
│ ├── EventTree.hs
│ ├── Types.hs
│ └── Universe.hs
├── Setup.hs
├── Tests
├── .gitignore
├── AppoxyHiringTask
│ ├── Lucky.hs
│ ├── StringOptimization.hs
│ ├── a.txt
│ ├── b.txt
│ └── lucky.txt
├── ArrowsAndFrees
│ ├── ArrEff.hs
│ ├── ArrowizedDSL.hs
│ ├── ArrowsResearch.hs
│ ├── FreeArrows.hs
│ ├── FreeDSL.hs
│ ├── FreeIODSL.hs
│ ├── Hardware.hs
│ └── HardwareTypes.hs
├── BinaryTreeWithKeys.hs
├── Combinations.hs
├── Curring.hs
├── Dividing.hs
├── DoNotationTest.hs
├── ExprParsingTest.hs
├── Fact.hs
├── FactAndFib.hs
├── FailureProbability
│ ├── FailureProbability.hs
│ ├── compile.cmd
│ └── run.cmd
├── Fib.hs
├── FinanceTree.hs
├── FizzBuzz.hs
├── FizzBuzz2.hs
├── FizzBuzz3.hs
├── FizzBuzz4.hs
├── FizzBuzz5.hs
├── FizzBuzz6Free.hs
├── Fractal
│ ├── .gitignore
│ ├── FractalComonad.hs
│ ├── FractalOfFrcactals.hs
│ └── FractalWithData.hs
├── GameOfLife.hs
├── HaskellSkbRii
│ ├── Task1
│ │ ├── FizzBuzz.hs
│ │ └── FizzBuzzes.txt
│ ├── Task2
│ │ ├── BlankSolver.hs
│ │ ├── Solution8.txt
│ │ └── TinkAndKiki.hs
│ └── Task3
│ │ ├── Interpreter.hs
│ │ ├── Language.hs
│ │ └── TestInput.txt
├── HighOrderFuncs.hs
├── InfSum.hs
├── Kleisli.hs
├── Language.hs
├── Lessons
│ ├── ListFold.hs
│ ├── ListMap.hs
│ └── Structure.txt
├── ListManipulation.hs
├── LookAndSay.hs
├── Maybe.hs
├── ModuleAbstraction
│ ├── Main.hs
│ ├── PathFind.hs
│ └── PathFind
│ │ ├── AStar.hs
│ │ └── Dijkstra.hs
├── MonadAbstraction
│ ├── Language.hs
│ └── StateMonad.hs
├── ParseAndXmlTest.hs
├── ParseAndXmlTest.hs~
├── Person.xml
├── Phonebook.hs
├── RandomNums.hs
├── ReadWriteFile.hs
├── Robotics
│ ├── Task1.hs
│ ├── Task2.hs
│ └── Task3.hs
├── Rogulike
│ ├── ComonadEffectTest.hs
│ ├── ComonadEffectTest2.hs
│ └── RogueLike.hs
├── STM
│ ├── ConcurrentSTM.hs
│ ├── StmsMap.hs
│ └── philosopers
│ │ ├── .gitignore
│ │ ├── ChangeLog.md
│ │ ├── LICENSE
│ │ ├── README.md
│ │ ├── Setup.hs
│ │ ├── app
│ │ └── Main.hs
│ │ ├── package.yaml
│ │ ├── src
│ │ ├── Philosophers.hs
│ │ ├── Philosophers
│ │ │ ├── Log.hs
│ │ │ ├── STM.hs
│ │ │ ├── Snapshot.hs
│ │ │ └── Types.hs
│ │ └── Philosophers2
│ │ │ └── STM.hs
│ │ ├── stack.yaml
│ │ └── test
│ │ └── Spec.hs
├── STree.hs
├── ScaleCollect.hs
├── SizeTreap.hs
├── SlyPercents.hs
├── SlyPercents.txt
├── StateInjection
│ ├── StateInjectionTest.hs
│ └── StateInjectionTest2.hs
├── StateTest.hs
├── StateTransformerTest.hs
├── StateTransformerTest2.hs
├── StringManipulation.hs
├── TH
│ ├── WiseConstructor.hs
│ └── WiseConstructorTH.hs
├── TestDataGeneration.hs
├── TextRatio.hs
├── TextRatio2.hs
├── TextRatio3.hs
├── Tmp.hs
├── TransitionGraph
│ └── transition-graph
│ │ ├── .gitignore
│ │ ├── ChangeLog.md
│ │ ├── LICENSE
│ │ ├── README.md
│ │ ├── Setup.hs
│ │ ├── app
│ │ ├── AdvGame
│ │ │ ├── AdvGameRuntime.hs
│ │ │ └── Lang.hs
│ │ └── Main.hs
│ │ ├── package.yaml
│ │ ├── src
│ │ ├── Data
│ │ │ └── Exists.hs
│ │ ├── Lib.hs
│ │ └── TransitionGraph
│ │ │ ├── Graph.hs
│ │ │ ├── Interpreter.hs
│ │ │ └── Runtime.hs
│ │ ├── stack.yaml
│ │ └── test
│ │ ├── Spec.hs
│ │ └── TransitionGraphSpec.hs
├── TypeClasses
│ └── TypeClasses.hs
├── Types
│ ├── Command.hs
│ ├── Hardware1.hs
│ ├── Hardware2.hs
│ ├── PhantomTypeCoerce.hs
│ ├── PhantomTypeHints.hs
│ ├── Test.hs
│ ├── TypeCalculation.hs
│ ├── TypeFamilies
│ │ ├── TypeFamilyTest1.hs
│ │ ├── TypeFamilyTest2.hs
│ │ └── TypeFamilyTest3.hs
│ ├── YonedaLemma.hs
│ └── dimensions
│ │ ├── LICENSE
│ │ ├── README.md
│ │ ├── Setup.hs
│ │ ├── app
│ │ └── Main.hs
│ │ ├── dimensions.cabal
│ │ ├── src
│ │ ├── Dimensions.hs
│ │ └── Lib.hs
│ │ ├── stack.yaml
│ │ └── test
│ │ ├── DimensionsSpec.hs
│ │ └── Spec.hs
├── XmlParsing
│ ├── Main.hs
│ ├── Test.hs
│ ├── log.xml
│ └── test.xml
├── fizzBuzzes.txt
├── myName.txt
├── taggedSymbols.html
├── taggedSymbols.txt
├── taggedSymbols2.html
├── taggedSymbols3.html
├── taggedSymbols4.html
├── test.txt
├── text.txt
└── tree.txt
└── dist
└── setup-config
/.gitignore:
--------------------------------------------------------------------------------
1 |
2 | /Programs/BlueFont/p_text.txt
3 | /Programs/BlueFont/text.txt
4 | /Exercises/output.txt
5 | /Exercises/perms2.txt
6 | /Exercises/permutations.txt
--------------------------------------------------------------------------------
/Algorithms.cabal:
--------------------------------------------------------------------------------
1 | -- Algorithms.cabal auto-generated by cabal init. For additional
2 | -- options, see
3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
4 | -- The name of the package.
5 | Name: Algorithms
6 |
7 | -- The package version. See the Haskell package versioning policy
8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
9 | -- standards guiding when and how versions should be incremented.
10 | Version: 0.0.5
11 |
12 | -- A short (one-line) description of the package.
13 | -- Synopsis:
14 |
15 | -- A longer description of the package.
16 | -- Description:
17 |
18 | -- The license under which the package is released.
19 | License: BSD3
20 |
21 | -- The file containing the license text.
22 | License-file: LICENSE
23 |
24 | -- The package author(s).
25 | Author: Granin, Alexandr
26 |
27 | -- An email address to which users can send suggestions, bug reports,
28 | -- and patches.
29 | Maintainer: graninas@gmail.com
30 |
31 | -- A copyright notice.
32 | -- Copyright:
33 |
34 | Category: Data
35 |
36 | Build-type: Simple
37 |
38 | -- Extra files to be distributed with the package, such as examples or
39 | -- a README.
40 | -- Extra-source-files:
41 |
42 | -- Constraint on the version of Cabal needed to build this package.
43 | Cabal-version: >=1.2
44 |
45 |
46 | Library
47 | -- Modules exported by the library.
48 | Exposed-modules: Examples.SizeTreap, Data.Infinitable, Data.Tree.Treap, Data.Tree.RandomTreap, Data.Tree.BinaryTree
49 |
50 | -- Packages needed in order to build this package.
51 | -- Build-depends:
52 |
53 | -- Modules not exported by this package.
54 | -- Other-modules:
55 |
56 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
57 | -- Build-tools:
58 |
--------------------------------------------------------------------------------
/Data/Infinitable.hs:
--------------------------------------------------------------------------------
1 | {-
2 | By Denis Krjuchkov
3 | http://stackoverflow.com/questions/2354707/in-haskell-is-there-num-a-infinity-a
4 | -}
5 |
6 | module Infinitable where
7 |
8 | data Infinitable a = NegativeInfinity | Regular a | PositiveInfinity
9 | deriving (Eq, Show)
10 |
11 | instance Ord a => Ord (Infinitable a) where
12 | compare NegativeInfinity NegativeInfinity = EQ
13 | compare PositiveInfinity PositiveInfinity = EQ
14 | compare NegativeInfinity _ = LT
15 | compare PositiveInfinity _ = GT
16 | compare _ PositiveInfinity = LT
17 | compare _ NegativeInfinity = GT
18 | compare (Regular x) (Regular y) = compare x y
19 |
20 | main =
21 | let five = Regular 5
22 | pinf = PositiveInfinity::Infinitable Integer
23 | ninf = NegativeInfinity::Infinitable Integer
24 | results = [(pinf > five), (ninf < pinf), (five > ninf)]
25 | in
26 | do putStrLn (show results)
27 |
--------------------------------------------------------------------------------
/Data/Tree/Binary.hs:
--------------------------------------------------------------------------------
1 | module Data.Tree.Binary where
2 |
3 | import Prelude hiding (lookup)
4 |
5 | data Ord a => BTree a b =
6 | Leaf
7 | | Branch a b (BTree a b) (BTree a b)
8 | deriving (Show)
9 |
10 |
11 | leaf :: BTree a b
12 | leaf = Leaf
13 |
14 | branch :: Ord a => a -> b -> BTree a b -> BTree a b -> BTree a b
15 | branch = Branch
16 |
17 | left (Branch _ _ l _) = l
18 | right (Branch _ _ _ r) = r
19 |
20 | lookup :: Ord a => a -> BTree a b -> Maybe b
21 | lookup _ Leaf = Nothing
22 | lookup key (Branch k v ltree rtree) | key == k = Just v
23 | | key < k = lookup key ltree
24 | | otherwise = lookup key rtree
25 |
26 | insert :: Ord a => (a, b) -> BTree a b -> BTree a b
27 | insert (key, val) Leaf = Branch key val Leaf Leaf
28 | insert p@(key, val) (Branch k v ltree rtree) | key == k = Branch key val ltree rtree
29 | | key < k = Branch k v (insert p ltree) rtree
30 | | otherwise = Branch k v ltree (insert p rtree)
31 |
32 | minBranch :: Ord a => BTree a b -> BTree a b
33 | minBranch m@(Branch k v Leaf _) = m
34 | minBranch (Branch _ _ l@(Branch _ _ _ _) _) = minBranch l
35 | minBranch _ = Leaf
36 |
37 | delete :: Ord a => a -> BTree a b -> BTree a b
38 | delete _ Leaf = Leaf
39 | delete key (Branch k v ltree Leaf) | key == k = ltree
40 | delete key (Branch k v ltree rtree) | key == k = let mb@(Branch mk mv _ _) = minBranch rtree
41 | in Branch mk mv ltree (delete mk rtree)
42 | | key < k = Branch k v (delete key ltree) rtree
43 | | key > k = Branch k v ltree (delete key ltree)
44 |
45 | fromList :: Ord a => [(a, b)] -> BTree a b
46 | fromList = foldr insert Leaf
47 |
48 | toList :: Ord key => BTree key value -> [(key, value)]
49 | toList Leaf = []
50 | toList (Branch k v ltree rtree) = ((k, v) : toList ltree) ++ toList rtree
--------------------------------------------------------------------------------
/Data/Tree/RandomTreap.hs:
--------------------------------------------------------------------------------
1 | module RandomTreap where
2 |
3 | import qualified Treap as T
4 | import qualified System.Random as R
5 |
6 | newtype RTreap g k p v = RT (g, T.Treap k p v)
7 | deriving Show
8 |
9 | insert :: (R.RandomGen g, Ord a, Enum a, Ord b, Num b, R.Random b) => T.RecalcFunc a b c -> (a, c) -> RTreap g a b c -> RTreap g a b c
10 | insert f (k, v) (RT (g, tree)) = let (p, g') = R.randomR (-1000, 1000) g
11 | in RT (g', T.insert f (k, p, v) tree)
12 |
13 | delete :: (Ord a, Enum a, Ord b) => a -> T.RecalcFunc a b c -> RTreap g a b c -> RTreap g a b c
14 | delete _ _ (RT (g, T.Leaf)) = RT (g, T.Leaf)
15 | delete x0 f (RT (g, tree)) = RT (g, T.delete x0 f tree)
16 |
17 | fromList :: (R.RandomGen g, Ord a, Enum a, Ord b, Num b, R.Random b) => g -> T.RecalcFunc a b c -> [(a, c)] -> RTreap g a b c
18 | fromList g f = foldr (insert f) (RT (g, T.Leaf))
19 |
20 | toList :: (Ord a, Enum a, Ord b) => RTreap g a b c -> [(a, c)]
21 | toList (RT (_, tree)) = [(k, v) | (k, _, v) <- T.toList tree]
22 |
23 | toSortedListL :: (Ord a, Enum a, Ord b) => RTreap g a b c -> [(a, c)]
24 | toSortedListL (RT (_, tree)) = [(k, v) | (k, _, v) <- T.toSortedListL tree]
25 |
26 | toSortedListR :: (Ord a, Enum a, Ord b) => RTreap g a b c -> [(a, c)]
27 | toSortedListR (RT (_, tree)) = [(k, v) | (k, _, v) <- T.toSortedListR tree]
28 |
29 | val :: (Ord a, Enum a, Ord b) => T.Treap a b Int -> Int
30 | val T.Leaf = 0
31 | val (T.Branch _ _ v _ _) = v
32 |
33 | recalc :: (Ord a, Enum a, Ord b) => T.RecalcFunc a b Int
34 | recalc l r = val l + val r
35 |
36 | testData :: [(Int, Int)]
37 | testData = [(1, 2), (3, 6), (6, 44), (7, 0), (2, 85), (4, -2), (5, 4), (8, 21)]
--------------------------------------------------------------------------------
/Data/Tree/Treap.hs:
--------------------------------------------------------------------------------
1 | module Treap where
2 |
3 | import Prelude hiding (lookup)
4 |
5 | data (Ord a, Enum a, Ord b) => Treap a b c =
6 | Leaf
7 | | Branch a b c (Treap a b c) (Treap a b c)
8 | deriving (Show)
9 |
10 | type RecalcFunc a b c = Treap a b c -> Treap a b c -> c
11 |
12 | leaf :: Treap a b c
13 | leaf = Leaf
14 |
15 | branch :: (Ord a, Enum a, Ord b) => a -> b -> c -> Treap a b c -> Treap a b c -> Treap a b c
16 | branch = Branch
17 |
18 | left (Branch _ _ _ l _) = l
19 | right (Branch _ _ _ _ r) = r
20 |
21 | singleton :: (Ord a, Enum a, Ord b) => (a, b, c) -> Treap a b c
22 | singleton (k, p, v) = Branch k p v Leaf Leaf
23 |
24 | merge :: (Ord a, Enum a, Ord b) => RecalcFunc a b c -> Treap a b c -> Treap a b c -> Treap a b c
25 | merge _ Leaf x = x
26 | merge _ x Leaf = x
27 | merge _ (Branch k1 _ _ _ _) (Branch k2 _ _ _ _) | k1 > k2 = undefined
28 | merge f l@(Branch k1 p1 v1 ll lr) r@(Branch k2 p2 v2 rl rr) | p1 > p2 = let subTree = merge f lr r
29 | in Branch k1 p1 (f subTree ll) ll subTree
30 | | p1 <= p2 = let subTree = merge f l rl
31 | in Branch k2 p2 (f subTree rr) subTree rr
32 |
33 | split :: (Ord a, Enum a, Ord b) => a -> RecalcFunc a b c -> Treap a b c -> (Treap a b c, Treap a b c)
34 | split _ _ Leaf = (Leaf, Leaf)
35 | split x0 f (Branch k p v l r) | k <= x0 = let (l', r') = split x0 f r
36 | in (Branch k p (f l l') l l', r')
37 | | k > x0 = let (l', r') = split x0 f l
38 | in (l', Branch k p (f r' r) r' r)
39 |
40 | insert :: (Ord a, Enum a, Ord b) => RecalcFunc a b c -> (a, b, c) -> Treap a b c -> Treap a b c
41 | insert _ (x0, p, v) Leaf = Branch x0 p v Leaf Leaf
42 | insert f (x0, p, v) tree = let (l, r) = split x0 f tree
43 | in merge f (merge f l (Branch x0 p v Leaf Leaf)) r
44 |
45 | delete :: (Ord a, Enum a, Ord b) => a -> RecalcFunc a b c -> Treap a b c -> Treap a b c
46 | delete _ _ Leaf = Leaf
47 | delete x0 f tree = let
48 | (l, r) = split (pred x0) f tree
49 | (l', r') = split x0 f r
50 | in merge f l r'
51 |
52 | lookup :: (Ord a, Enum a, Ord b) => a -> Treap a b c -> Maybe (a, b, c)
53 | lookup k Leaf = Nothing
54 | lookup k (Branch k1 p1 v1 l r) | k == k1 = Just (k1, p1, v1)
55 | | k < k1 = lookup k l
56 | | k > k1 = lookup k r
57 |
58 | fromList :: (Ord a, Enum a, Ord b) => RecalcFunc a b c -> [(a, b, c)] -> Treap a b c
59 | fromList f = foldr (insert f) Leaf
60 |
61 | toList :: (Ord a, Enum a, Ord b) => Treap a b c -> [(a, b, c)]
62 | toList Leaf = []
63 | toList (Branch k p v l r) = ((k, p, v) : toList l) ++ toList r
64 |
65 | toSortedListL :: (Ord a, Enum a, Ord b) => Treap a b c -> [(a, b, c)]
66 | toSortedListL Leaf = []
67 | toSortedListL (Branch k p v l r) = toSortedListL l ++ ((k, p, v) : toSortedListL r)
68 |
69 | toSortedListR :: (Ord a, Enum a, Ord b) => Treap a b c -> [(a, b, c)]
70 | toSortedListR Leaf = []
71 | toSortedListR (Branch k p v l r) = toSortedListR r ++ ((k, p, v) : toSortedListR l)
--------------------------------------------------------------------------------
/Haskell-Algorithms.cabal:
--------------------------------------------------------------------------------
1 | -- Haskell-Algorithms.cabal auto-generated by cabal init. For
2 | -- additional options, see
3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
4 | -- The name of the package.
5 | Name: Haskell-Algorithms
6 |
7 | -- The package version. See the Haskell package versioning policy
8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
9 | -- standards guiding when and how versions should be incremented.
10 | Version: 0.1
11 |
12 | -- A short (one-line) description of the package.
13 | Synopsis: Algorithms, miniprograms, exercises, prototypes and materials for Haskell learning.
14 |
15 | -- A longer description of the package.
16 | -- Description:
17 |
18 | -- URL for the project homepage or repository.
19 | Homepage: https://github.com/graninas/Haskell-Algorithms
20 |
21 | -- The license under which the package is released.
22 | License: GPL-3
23 |
24 | -- The file containing the license text.
25 | License-file: LICENSE
26 |
27 | -- The package author(s).
28 | Author: Alexandr Granin
29 |
30 | -- An email address to which users can send suggestions, bug reports,
31 | -- and patches.
32 | Maintainer: graninas@gmail.com
33 |
34 | -- A copyright notice.
35 | -- Copyright:
36 |
37 | Category: Algorithms
38 |
39 | Build-type: Simple
40 |
41 | -- Extra files to be distributed with the package, such as examples or
42 | -- a README.
43 | -- Extra-source-files:
44 |
45 | -- Constraint on the version of Cabal needed to build this package.
46 | Cabal-version: >=1.2
47 |
48 |
49 | Library
50 | -- Modules exported by the library.
51 | Exposed-modules: Tests.Kleisli, Prototypes.Adv2Game.Types2, Prototypes.Adv2Game.Types, Programs.NgnTraffic.Types, Programs.NgnTraffic.Tools, Programs.NgnTraffic.Options, Programs.NgnTraffic.NgnTraffic, Programs.NgnTraffic.FileListProcess, Programs.NgnTraffic.DataProcess, Programs.NgnTraffic.Constants, Programs.HabrFormat.HabrFormat, Programs.BlueFont.BlueFont, Exercises.FizzBuzz, Exercises.FinanceTree, Exercises.Dividing, Examples.SizeTreap, Data.Infinitable, Data.Tree.Treap, Data.Tree.RandomTreap, Data.Tree.Binary
52 |
53 | -- Packages needed in order to build this package.
54 | -- Build-depends:
55 |
56 | -- Modules not exported by this package.
57 | -- Other-modules:
58 |
59 | -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
60 | -- Build-tools:
61 |
--------------------------------------------------------------------------------
/Materials/Back to the Future - Tech Talks NSU/Adapter.hs:
--------------------------------------------------------------------------------
1 |
2 | module Main where
3 |
4 | import qualified Data.Set as Set
5 |
6 | type Node = Int
7 | type Nodes = [Node]
8 | type TableGraph = [ (Node, Nodes) ]
9 |
10 | type Successors = Set.Set Node
11 | type Graph = Node -> Successors
12 |
13 | tarjanAlg :: Graph -> [Nodes]
14 | tarjanAlg = undefined -- some impl
15 |
16 | getNodes n tg = maybe [] id (lookup n tg)
17 |
18 | asGraph :: TableGraph -> Graph
19 | asGraph tg node = Set.fromList succs
20 | where
21 | succs = maybe [] id (lookup node tg)
22 |
23 | asGraph' :: TableGraph -> Graph
24 | asGraph' tg = Set.fromList . flip getNodes tg
25 |
26 |
27 | adaptedTarjanAlg :: TableGraph -> [Nodes]
28 | adaptedTarjanAlg = tarjanAlg . asGraph
29 |
30 |
31 | tableGraph :: TableGraph
32 | tableGraph = [ (1, [2, 3])
33 | , (2, [])
34 | , (3, [1, 2]) ]
35 |
36 | cycles = tarjanAlg (asGraph tableGraph)
37 |
38 | cycles' = adaptedTarjanAlg tableGraph
39 |
--------------------------------------------------------------------------------
/Materials/Back to the Future - Tech Talks NSU/Adapter2.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 |
4 |
5 |
6 |
7 |
8 |
--------------------------------------------------------------------------------
/Materials/Back to the Future - Tech Talks NSU/Strategy.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Back to the Future - Tech Talks NSU/Strategy.hs
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/ExistentialAntipattern.hs:
--------------------------------------------------------------------------------
1 |
2 | module World.Plasma where
3 |
4 | data Plasma = Plasma { plasmaPlayer :: Player }
5 |
6 |
7 | module World.Karyon where
8 |
9 | data Karyon = Karyon { karyonPlayer :: Player
10 | , karyonEnergy :: Energy }
11 |
12 |
13 |
14 | class Active i where
15 | activate :: i -> Point -> World -> OperatedWorld -> OperatedWorld
16 |
17 |
18 | -- module World.Karyon:
19 | instance Active Karyon where
20 | activate = undefined
21 |
22 |
23 | -- module World.Plasma:
24 | instance Active Plasma where
25 | activate = undefined
26 |
27 |
28 | -- module GameLogic.Types:
29 | {-# LANGUAGE ExistentialQuantification #-}
30 | data ActiveItem = forall i. Active i => MkActiveItem i
31 | type World = M.Map Point ActiveItem
32 |
33 | instance Active ActiveItem where
34 | activate (MkActiveItem i) = activate i
35 |
36 | worldMapFromList :: [(Point, ActiveItem)] -> World
37 | worldMapFromList = M.fromList
38 |
39 |
40 | packItem :: Active i => i -> ActiveItem
41 | packItem = MkActiveItem
42 |
43 | packedKaryon = packItem (Karyon 1 100)
44 | packedPlasma = packItem (Plasma 1)
45 |
46 | world = M.fromList [ (Point 1 1 1, packedKaryon)
47 | , (Point 1 1 2, packedPlasma) ]
48 |
49 | stepWorld world = M.foldrWithKey f M.empty world
50 | where
51 | f point (MkActiveItem i) operatedWorld = activate i point world operatedWorld
52 |
53 | stepWorld = M.foldrWithKey activate M.empty
54 |
55 |
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-1.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-2-Problem1.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-2-Problem1.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-2-Problem2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-2-Problem2.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-2-Problem3.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-2-Problem3.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-2-Problem4.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-2-Problem4.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/GoodDesign-2.png:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Design and Architecture in FP/GoodDesign-2.png
--------------------------------------------------------------------------------
/Materials/Design and Architecture in FP/WorldCellAdt.hs:
--------------------------------------------------------------------------------
1 | module GameLogic.Types where
2 | import qualified Data.Map as M
3 |
4 | data Item = Karyon ...
5 | | Plasma ...
6 | | Mitochondrion ...
7 | | Stone ...
8 |
9 | type World = M.Map Point Item
10 | type OperatedWorld = World
11 |
12 | module GameLogic.Logic where
13 | import GameLogic.Types
14 |
15 | stepWorld :: World -> World
16 | apply :: World -> Item -> OperatedWorld -> OperatedWorld
17 |
18 |
19 | import GameLogic.Karyon as Karyon
20 | import GameLogic.Plasma as Plasma
21 |
22 | apply w (Karyon a b c) ow = Karyon.apply w (a, b, c) ow
23 | apply w (Plasma c d) ow = Plasma.apply w (c, d) ow
24 | apply w (Mitochondrion e f g) ow = Mitochondrion.apply w (e, f, g) ow
25 | ...
26 |
27 | getEnergy :: Item -> Int
28 | getEnergy (Karyon e b c) = e
29 | getEnergy (Mitochondrion e f g) = e
30 | getEnergy _ = error "getEnergy unsupported."
31 |
32 |
33 | main = do
34 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Materials/Game Development Materials.txt:
--------------------------------------------------------------------------------
1 | Netwire
2 | -------
3 |
4 | Tetris:
5 | http://scrambledeggsontoast.github.io/2014/09/23/tetris-netwire/#fn:whynetwire
6 |
7 | Netwire-Pong:
8 | https://github.com/crockeo/netwire-pong
9 |
10 | Netwire-Tutorial:
11 | https://github.com/crockeo/netwire-tutorial
12 |
13 | Input combinators for Netwire:
14 | https://github.com/Mokosha/netwire-input
15 | https://github.com/Mokosha/netwire-input-glfw
16 |
17 | Full example of Netwire (ver. < 5.0)
18 | http://stackoverflow.com/questions/14787797/full-example-for-netwire
19 |
20 | Game engines
21 | ------------
22 |
23 | Hickory:
24 | https://github.com/asivitz/Hickory
25 |
26 | LambdaHack:
27 | https://github.com/LambdaHack/LambdaHack
28 |
29 | Elerea
30 | ------
31 |
32 | Writing a game in Haskell:
33 | http://www.youtube.com/watch?v=1MNTerD8IuI
34 |
35 | Games
36 | -----
37 |
38 | 3D Snake:
39 | https://github.com/mikeplus64/plissken
40 |
41 | Varoius prototypes:
42 | https://github.com/mlesniak/game
43 |
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/Haskell в реальном мире.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Haskell в реальном мире - Статья/Haskell в реальном мире.txt
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/merger 0.13.hs:
--------------------------------------------------------------------------------
1 | import System (getArgs)
2 | import System.Directory (getDirectoryContents, getCurrentDirectory)
3 | import Char (isDigit)
4 |
5 | type Year = Int
6 | type Month = Int
7 | type DateRange = (Year, Month)
8 |
9 | defaultDateRange :: DateRange
10 | defaultDateRange = (2011, 4)
11 |
12 | readDateRange :: Read a => String -> Maybe a
13 | readDateRange str = case reads str of
14 | [(x, _)] -> Just x
15 | _ -> Nothing
16 |
17 | isFileForMerge :: String -> DateRange -> Bool
18 | isFileForMerge s (y, m) | (25 == length s) && (all isDigit (take 21 s)) =
19 | let
20 | ry = read ((take 4 . drop 5) s)
21 | rm = read ((take 2 . drop 9) s)
22 | in ry == y && rm == m
23 | isFileForMerge _ _ | otherwise = False
24 |
25 | isTxt :: String -> Bool
26 | isTxt s = (drop ((length s) - 3) s) == "txt"
27 |
28 | filesToMerge :: [String] -> DateRange -> [String]
29 | filesToMerge ss dr = filter (\x -> isTxt x && isFileForMerge x dr) ss
30 |
31 |
32 | main :: IO ()
33 | main = do
34 | args <- getArgs
35 | curDir <- getCurrentDirectory
36 | dirContents <- getDirectoryContents curDir
37 | let maybeDateRange = case args of
38 | (a:b:_) -> readDateRange (unwords [a, b])
39 | _ -> Just defaultDateRange
40 | case maybeDateRange of
41 | Just dr -> do
42 | fsToMerge = filesToMerge dirContents dr
43 | fsContents = merge fsToMerge
44 | putStrLn ("Files to merge: " ++ unlines fsToMerge)
45 | Nothing -> putStrLn ("Invalid date range.")
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/merger 0.14.hs:
--------------------------------------------------------------------------------
1 | import System (getArgs)
2 | import System.Directory (getDirectoryContents, getCurrentDirectory)
3 | import Char (isDigit)
4 | import Text.Printf (printf)
5 | import qualified Time as T
6 |
7 | type Year = Int
8 | type Month = Int
9 | type DateRange = (Year, Month)
10 |
11 | defaultDateRange :: T.CalendarTime -> DateRange
12 | defaultDateRange (T.CalendarTime y m _ _ _ _ _ _ _ _ _ _)= (y, fromEnum m + 1)
13 |
14 | readDateRange :: Read a => String -> Maybe a
15 | readDateRange str = case reads str of
16 | [(x, _)] -> Just x
17 | _ -> Nothing
18 |
19 | isFileForMerge :: String -> DateRange -> Bool
20 | isFileForMerge s (y, m) | (25 == length s) && (all isDigit (take 21 s)) =
21 | let
22 | ry = read ((take 4 . drop 5) s)
23 | rm = read ((take 2 . drop 9) s)
24 | in ry == y && rm == m
25 | isFileForMerge _ _ | otherwise = False
26 |
27 | isTxt :: String -> Bool
28 | isTxt s = (drop ((length s) - 3) s) == "txt"
29 |
30 | filesToMerge :: [String] -> DateRange -> [String]
31 | filesToMerge ss dr = filter (\x -> isTxt x && isFileForMerge x dr) ss
32 |
33 | merge :: [String] -> IO [String]
34 | merge fsToMerge = mapM readFile fsToMerge
35 |
36 | newFileName :: DateRange -> String
37 | newFileName (y, m) = printf "%s.%02s.txt" (show y) (show m)
38 |
39 | main :: IO ()
40 | main = do
41 | args <- getArgs
42 | curDir <- getCurrentDirectory
43 | dirContents <- getDirectoryContents curDir
44 | curTime <- T.getClockTime
45 | monthAgoTime <- return $ T.addToClockTime (T.TimeDiff 0 (-1) 0 0 0 0 0) curTime
46 | calendarMonthAgoTime <- T.toCalendarTime monthAgoTime
47 | let maybeDateRange = case args of
48 | (a:b:_) -> readDateRange (unwords [a, b])
49 | _ -> Just $ defaultDateRange calendarMonthAgoTime
50 | case maybeDateRange of
51 | Just dr -> do
52 | let fsToMerge = filesToMerge dirContents dr
53 | let fsToMergeCountStr = show $ length fsToMerge
54 | let mergeLog = (newFileName dr ++ ".log")
55 | let dateRangeMsg = "DateRange: " ++ show dr
56 | fsContents <- merge fsToMerge
57 | writeFile (newFileName dr) (unlines fsContents)
58 | writeFile mergeLog (unlines fsToMerge ++ printf "\n%s\nTotal files: %s" dateRangeMsg fsToMergeCountStr)
59 | putStrLn (unlines fsContents)
60 | putStrLn dateRangeMsg
61 | --putStrLn ("Files to merge: " ++ unlines fsToMerge)
62 | putStrLn (printf "Count of files: %s. See %s for file list." fsToMergeCountStr mergeLog)
63 | Nothing -> putStrLn ("Invalid date range.")
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/merger 0.16.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Haskell в реальном мире - Статья/merger 0.16.hs
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/merger 0.23.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Haskell в реальном мире - Статья/merger 0.23.hs
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/parser 0.12.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/Haskell в реальном мире - Статья/parser 0.12.hs
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/parser 0.2.hs:
--------------------------------------------------------------------------------
1 | import Data.List
2 |
3 | replaceChars :: Char -> Char -> Char -> Char
4 | replaceChars whatC withC c = if c == whatC then withC else c
5 |
6 | interestFields :: [String] -> [Int] -> [String]
7 | interestFields s takeWhat = undefined
8 |
9 | isR200 :: [String] -> Bool
10 | isR200 s = (head s) == "R200"
11 |
12 | processLine :: String -> String
13 | processLine s = if isR200 sInWords then unwords (interestFields sInWords [1,2,3] ) else []
14 | where sInWords = words ( map (replaceChars '|' ' ') s )
15 |
16 | processString :: String -> [String]
17 | processString s = map processLine (lines $ s)
18 |
19 | main :: IO ()
20 | main = do
21 | str <- readFile "merged.txt"
22 | putStrLn (intercalate "\r\n" (processString $ str))
23 |
--------------------------------------------------------------------------------
/Materials/Haskell в реальном мире - Статья/parser 0.6.hs:
--------------------------------------------------------------------------------
1 | import Data.List
isR200 :: [String] -> Bool
isR200 s = (head s) == "R200"
replaceChar :: Char -> Char -> Char -> Char
replaceChar whatC withC c = if c == whatC then withC else c
replaceSymbols :: String -> String
replaceSymbols s = map (replaceChar '|' ' ') (map (replaceChar ' ' '*') s)
takeInterest :: [String] -> [Int] -> [String]
takeInterest _ [] = []
takeInterest ss (n:ns) = [ss !! n] ++ takeInterest ss ns
interestFields :: [String] -> [Int] -> [String]
interestFields ss takeWhat | (maximum takeWhat) < length ss = takeInterest ss takeWhat
| otherwise = undefined
makeNewLine :: [String] -> String
makeNewLine str = map (replaceChar ' ' '|') (unwords (interestFields str [7,8,9]))
processLine :: String -> String
processLine s = if isR200 sInWords then map (replaceChar '*' ' ') (makeNewLine sInWords) else []
where sInWords = words . replaceSymbols $ s
processString :: String -> [String]
processString s = {-take 10-} (filter (\a -> a /= []) (map processLine (lines $ s)))
main :: IO ()
main = do
str <- readFile "merged.txt"
let processedStr = intercalate "\n" (processString $ str)
putStrLn processedStr
writeFile "processed.txt" processedStr
--------------------------------------------------------------------------------
/Materials/YAMT/Mike Vanier's monad tutorial part 1 - Translation.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/YAMT/Mike Vanier's monad tutorial part 1 - Translation.txt
--------------------------------------------------------------------------------
/Materials/YAMT/Mike Vanier's monad tutorial part 2 - Translation.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/YAMT/Mike Vanier's monad tutorial part 2 - Translation.txt
--------------------------------------------------------------------------------
/Materials/YAMT/Mike Vanier's monad tutorial part 3 - Translation.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/YAMT/Mike Vanier's monad tutorial part 3 - Translation.txt
--------------------------------------------------------------------------------
/Materials/YAMT/Mike Vanier's monad tutorial part 4 - Translation.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/YAMT/Mike Vanier's monad tutorial part 4 - Translation.txt
--------------------------------------------------------------------------------
/Materials/YAMT/Mike Vanier's monad tutorial part 5 - Translation.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Materials/YAMT/Mike Vanier's monad tutorial part 5 - Translation.txt
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/.gitignore:
--------------------------------------------------------------------------------
1 | *.hi
2 | *.o
3 | .buildDir
4 | .dist-buildwrapper
5 | .bin
6 | dist
7 | .project~
8 | *~
9 | .tree
10 | .swp
11 | ./GlossMetaLife
12 | .exe
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/Life.hs:
--------------------------------------------------------------------------------
1 | {-
2 | This code taken from Habrahabr:
3 | http://habrahabr.ru/post/225473/
4 | -}
5 |
6 | module Life where
7 |
8 | import Control.Comonad
9 | import Control.Applicative
10 |
11 | import Universe
12 |
13 | data Cell = Dead | Alive
14 | deriving (Eq, Show)
15 |
16 | nearest3 :: Universe a -> [a]
17 | nearest3 u = fmap extract [left u, u, right u]
18 |
19 | neighbours :: (Universe2 a) -> [a]
20 | neighbours u =
21 | [ nearest3 . extract . left
22 | , pure . extract . left . extract
23 | , pure . extract . right . extract
24 | , nearest3 . extract . right
25 | ] >>= ($ getUniverse2 u)
26 |
27 | rule :: Universe2 Cell -> Cell
28 | rule u
29 | | nc == 2 = extract u
30 | | nc == 3 = Alive
31 | | otherwise = Dead
32 | where nc = length $ filter (==Alive) (neighbours u)
33 |
34 | fromList :: a -> [a] -> Universe a
35 | fromList d (x:xs) = Universe (repeat d) x (xs ++ repeat d)
36 |
37 | fromList2 :: a -> [[a]] -> Universe2 a
38 | fromList2 d = Universe2 . fromList ud . fmap (fromList d)
39 | where ud = Universe (repeat d) d (repeat d)
40 |
41 | cells = [ [ Dead, Alive, Dead]
42 | , [Alive, Dead, Dead]
43 | , [Alive, Alive, Alive] ]
44 |
45 | initialModel :: Universe2 Cell
46 | initialModel = fromList2 Dead cells
47 |
48 | stepLifeUniverse = (=>> rule)
49 |
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/SampleCells.hs:
--------------------------------------------------------------------------------
1 | module SampleCells where
2 |
3 | import MetaLife
4 |
5 | metaCells = map (map zeroCellCreator) cellsGlider
6 |
7 | cells' = [[alive, alive, dead, alive, alive]]
8 |
9 | cells'' = [[alive, alive, alive]]
10 |
11 | cellsGlider = [ [ dead, alive, dead]
12 | , [alive, dead, dead]
13 | , [alive, alive, alive] ]
14 |
15 | cells''' = [ [dead, dead, dead, dead, alive, dead ]
16 | , [dead, dead, dead, alive, dead, dead ]
17 | , [dead, dead, dead, alive, alive, alive ]
18 | , [dead, dead, dead, dead, dead, dead ]
19 | , [dead, dead, dead, dead, dead, dead ]
20 | , [dead, dead, dead, dead, dead, dead ]
21 | , [dead, dead, dead, dead, dead, dead ]
22 | , [dead, dead, dead, dead, dead, dead ]
23 | , [alive, dead, alive, alive, alive, alive ]
24 | , [dead, alive, alive, alive, dead, alive ]
25 | , [alive, dead, dead, alive, alive, alive ]
26 | , [dead, alive, dead, dead, alive, dead ]
27 | , [alive, dead, dead, alive, alive, dead ]
28 | , [dead, alive, alive, dead, dead, alive ]
29 | , [alive, dead, alive, alive, alive, alive ]
30 | , [dead, alive, alive, dead, alive, alive ]
31 | , [alive, dead, alive, dead, alive, alive ]
32 | , [dead, alive, dead, dead, alive, dead ]
33 | , [alive, dead, alive, alive, dead, dead ]
34 | , [dead, alive, alive, dead, alive, alive ]
35 | , [alive, dead, dead, alive, dead, dead ]
36 | ]
37 |
38 | testLine = [ alive : replicate 28 dead ++ [alive]]
39 | testBlock = [ replicate 14 dead ++ [alive, alive] ++ replicate 14 dead]
40 | fillers n = replicate n (replicate 30 dead)
41 |
42 | testCells = testLine
43 | ++ fillers 6
44 | ++ testLine
45 | ++ fillers 6
46 | ++ testBlock
47 | ++ testBlock
48 | ++ fillers 6
49 | ++ testLine
50 | ++ fillers 6
51 | ++ testLine
52 |
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/Universe.hs:
--------------------------------------------------------------------------------
1 | {-
2 | This code taken from Habrahabr:
3 | http://habrahabr.ru/post/225473/
4 | -}
5 | module Universe where
6 |
7 | import Control.Comonad
8 | import qualified Data.Vector as V
9 |
10 | type Current = Int
11 | data Universe a = Universe (V.Vector a) Int
12 | newtype Universe2 a = Universe2 { getUniverse2 :: Universe (Universe a) }
13 |
14 | left :: Universe a -> Universe a
15 | left (Universe v 0) = Universe v (V.length v - 1)
16 | left (Universe v cur) = Universe v (cur - 1)
17 |
18 | right :: Universe a -> Universe a
19 | right (Universe v cur) | cur == (V.length v - 1) = Universe v 0
20 | | otherwise = Universe v (cur + 1)
21 |
22 | left2 = left . left
23 | left3 = left . left . left
24 |
25 | right2 = right . right
26 | right3 = right . right . right
27 |
28 | makeUniverse fl fr x@(Universe v cur) = newUniverse
29 | where
30 | s = V.length v
31 | lvs = if cur == 0 then [] else take cur . tail $ iterate fl x
32 | rvs = if cur == s - 1 then [] else take (s - cur - 1) . tail $ iterate fr x
33 | vs = lvs ++ [x] ++ rvs
34 | newUniverse = Universe (V.fromList vs) cur
35 |
36 | instance Functor Universe where
37 | fmap f (Universe v cur) = Universe (V.map f v) cur
38 |
39 | instance Comonad Universe where
40 | duplicate = makeUniverse left right
41 | extract (Universe v cur) = V.unsafeIndex v cur
42 |
43 | takeRange :: (Int, Int) -> Universe a -> [a]
44 | takeRange (a, b) (Universe v _) | a < 0 = V.toList $ V.slice (1 - a) (b - a + 1) v
45 | takeRange (a, b) (Universe v _) | a >= 0 = V.toList $ V.slice (a - 1) (b - a + 1) v
46 |
47 | instance Functor Universe2 where
48 | fmap f = Universe2 . (fmap . fmap) f . getUniverse2
49 |
50 | instance Comonad Universe2 where
51 | extract = extract . extract . getUniverse2
52 | duplicate = fmap Universe2 . Universe2 . shifted . shifted . getUniverse2
53 | where shifted :: Universe (Universe a) -> Universe (Universe (Universe a))
54 | shifted = makeUniverse (fmap left) (fmap right)
55 |
56 | nearest3 :: Universe a -> [a]
57 | nearest3 u = fmap extract [left u, u, right u]
58 |
59 | nearest5 :: Universe a -> [a]
60 | nearest5 u = fmap extract [left2 u, right2 u] ++ nearest3 u
61 |
62 | nearest7 :: Universe a -> [a]
63 | nearest7 u = fmap extract [left3 u, right3 u] ++ nearest5 u
64 |
65 | fromListU :: Int -> a -> [a] -> Universe a
66 | fromListU _ _ [] = error "Empty list."
67 | fromListU 0 _ _ = error "Invalid size."
68 | fromListU s zeroC xs | length xs > s = error "Invalid bounds."
69 | | otherwise =
70 | let unfilled = s - (length xs)
71 | unfR = unfilled `div` 2
72 | unfL = unfilled - unfR
73 | rsL = replicate unfL zeroC
74 | rsR = replicate unfR zeroC
75 | xs' = rsL ++ xs ++ rsR
76 | in Universe (V.fromList xs') 0
77 |
78 | fromList2 :: Int -> a -> [[a]] -> Universe2 a
79 | fromList2 s zeroC xss = Universe2 vss
80 | where
81 | zeroU = fromListU s zeroC . replicate s $ zeroC
82 | vs = map (fromListU s zeroC) xss
83 | vss = fromListU s zeroU vs
84 |
85 | toList2 :: Universe2 a -> [[a]]
86 | toList2 u = vs
87 | where
88 | (Universe vu' _) = getUniverse2 u
89 | getCells (Universe v _) = V.toList v
90 | vs = map getCells (V.toList vu')
91 |
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/config.txt:
--------------------------------------------------------------------------------
1 | # This is GlossMetaMetaLife config file.
2 | # Format:
3 | # f1 f2 f3 f4 f5 ra1 ra2 ra3 fieldSize totalIters itersPerSec mode
4 | # mode = Play | Simulate
5 | # ra1, ra2, ra3 - Rule Area for bottom, middle and top rule levels respectively,
6 | # where the bottom level is the level of real game of life.
7 | # Rule area defines the area where the alive cells counting.
8 | # RuleArea = Ring1 -- Classic ring of neighbour cells with the radius == 3.
9 | # | Ring2 -- Next ring with the radius == 5.
10 | # | Ring3 -- Next ring with the radius == 7.
11 | # The first conf is counting.
12 | #
13 |
14 | 2 1 0 0 0 Ring1 Ring2 Ring3 60 1000 4 Simulate
15 |
16 |
17 | 1 2 1 0 0 Ring1 Ring2 Ring3 60 1000 4 Simulate
18 | 0 0 0 1 1 Ring1 Ring2 Ring3 60 1000 4 Simulate
19 |
20 |
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/run.cmd:
--------------------------------------------------------------------------------
1 | ghc -O2 -threaded -rtsopts GlossMetaLife.hs
2 | .\GlossMetaLife +RTS -N8 -RTS
3 |
--------------------------------------------------------------------------------
/Programs/GameOfLifeComonad/run.sh:
--------------------------------------------------------------------------------
1 | rm *.hi *.o GlossMetaLife
2 | ghc -O2 -threaded -rtsopts GlossMetaLife.hs
3 | ./GlossMetaLife +RTS -N8 -RTS
4 |
--------------------------------------------------------------------------------
/Programs/HabrFormat/.gitignore:
--------------------------------------------------------------------------------
1 |
2 | *.exe
3 | *.o
4 | *.hi
--------------------------------------------------------------------------------
/Programs/HabrFormat/article.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/HabrFormat/article.html
--------------------------------------------------------------------------------
/Programs/HabrFormat/formated_article.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/HabrFormat/formated_article.html
--------------------------------------------------------------------------------
/Programs/NgnTraffic Old/LicenseTemplate.txt:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** NgnTrafficParser 1.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of NgnTrafficParser 1.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
--------------------------------------------------------------------------------
/Programs/NgnTraffic Old/merger.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic Old/merger.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic Old/parser.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic Old/parser.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic/.gitignore:
--------------------------------------------------------------------------------
1 |
2 | *.hi
3 | *.exe
4 | *.o
--------------------------------------------------------------------------------
/Programs/NgnTraffic/Constants.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic/Constants.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic/DataProcess.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic/DataProcess.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic/FileListProcess.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic/FileListProcess.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic/LicenseTemplate.txt:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** NgnTrafficParser 2.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of NgnTrafficParser 2.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
--------------------------------------------------------------------------------
/Programs/NgnTraffic/NgnTraffic.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic/NgnTraffic.hs
--------------------------------------------------------------------------------
/Programs/NgnTraffic/Options.hs:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** NgnTrafficParser 2.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of NgnTrafficParser 2.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
22 |
23 | module Options where
24 |
25 | import Types
26 | import qualified Data.List as L ((\\))
27 |
28 | optionsFromArgs :: [String] -> Options
29 | optionsFromArgs [] = []
30 | optionsFromArgs ("-f":fs) = case (reads . unwords) fs of
31 | [(idxList, rest)] -> (FieldsToCollect idxList) : ( (optionsFromArgs . words) rest)
32 | _ -> optionsFromArgs fs
33 |
34 | optionsFromArgs ("-ym":fs) = case (reads . unwords) fs of
35 | [(ym, rest)] -> (TargetYearMonth ym) : ( (optionsFromArgs . words) rest)
36 | _ -> optionsFromArgs fs
37 |
38 | optionsFromArgs ("-w":fs) = WaitAfterDone : optionsFromArgs fs
39 | optionsFromArgs (arg:args) = optionsFromArgs args
40 |
41 | defaultOptions :: FieldIndexes -> YearMonth -> Options
42 | defaultOptions fis ym = [FieldsToCollect fis, TargetYearMonth ym]
43 |
44 | compileOptions :: Options -> Options -> Options
45 | compileOptions opts defOpts = opts ++ (defOpts L.\\ opts)
46 |
47 | getYearMonth :: Options -> YearMonth
48 | getYearMonth [] = undefined
49 | getYearMonth ((TargetYearMonth x):_) = x
50 | getYearMonth (_:os) = getYearMonth os
51 |
52 | getFieldIndexes :: Options -> FieldIndexes
53 | getFieldIndexes [] = undefined
54 | getFieldIndexes ((FieldsToCollect x):_) = x
55 | getFieldIndexes (_:os) = getFieldIndexes os
56 |
57 | getWait :: Options -> Bool
58 | getWait = not . null . filter (== WaitAfterDone)
--------------------------------------------------------------------------------
/Programs/NgnTraffic/README:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/NgnTraffic/README
--------------------------------------------------------------------------------
/Programs/NgnTraffic/Tools.hs:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** NgnTrafficParser 2.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of NgnTrafficParser 2.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
22 |
23 | module Tools where
24 |
25 | import qualified System.Time as T (TimeDiff(..), CalendarTime(..), ClockTime(..), addToClockTime, toClockTime)
26 | import Data.Char (toUpper, toLower)
27 | import Types
28 |
29 | firstMonthDay :: T.CalendarTime -> T.CalendarTime
30 | firstMonthDay ct = ct {T.ctDay = 1}
31 |
32 | prevMonthBegin :: T.CalendarTime -> T.ClockTime
33 | prevMonthBegin curMonth = T.addToClockTime (T.TimeDiff 0 (-1) 0 0 0 0 0) (T.toClockTime $ firstMonthDay curMonth)
34 |
35 | toYearMonth :: T.CalendarTime -> YearMonth
36 | toYearMonth (T.CalendarTime y m _ _ _ _ _ _ _ _ _ _)= (y, fromEnum m + 1)
37 |
38 | capitalize :: String -> String
39 | capitalize [] = []
40 | capitalize (l:ls) = toUpper l : map toLower ls
41 |
42 |
--------------------------------------------------------------------------------
/Programs/NgnTraffic/Types.hs:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** NgnTrafficParser 2.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of NgnTrafficParser 2.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
22 |
23 | module Types where
24 |
25 | import qualified Data.ByteString.Char8 as C
26 |
27 | type Year = Int
28 | type Month = Int
29 | type YearMonth = (Year, Month)
30 |
31 | type ResFilePath = FilePath
32 |
33 | type FieldIndex = Int
34 | type FieldIndexes = [FieldIndex]
35 | type FieldDelimiter = Char
36 | type Fields = [C.ByteString]
37 |
38 | data Predicate = NotInList [C.ByteString]
39 | | InList [C.ByteString]
40 | | Like [C.ByteString]
41 | | LengthLess Int
42 | type PredicateMap = [(FieldIndex, Predicate)]
43 |
44 |
45 | data Option = FieldsToCollect FieldIndexes
46 | | TargetYearMonth YearMonth
47 | | WaitAfterDone
48 | deriving (Show, Read)
49 |
50 | type Options = [Option]
51 |
52 | instance Eq Option where
53 | (FieldsToCollect x) == (FieldsToCollect y) = True
54 | (TargetYearMonth x) == (TargetYearMonth y) = True
55 | (WaitAfterDone) == (WaitAfterDone) = True
56 | a == b = False
57 |
--------------------------------------------------------------------------------
/Programs/RestCorrecting/LicenseTemplate.txt:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** RestCorrecting 1.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of RestCorrecting 1.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
--------------------------------------------------------------------------------
/Programs/RestCorrecting/README:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/RestCorrecting/README
--------------------------------------------------------------------------------
/Programs/RestCorrecting/Sql.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/RestCorrecting/Sql.hs
--------------------------------------------------------------------------------
/Programs/RestCorrecting/TestData.hs:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** RestCorrecting 1.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of RestCorrecting 1.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
22 |
23 | module TestData where
24 |
25 |
26 | import Types
27 |
28 | testDataCharges :: Charges
29 | testDataCharges = [
30 | (882513, 83, 146 , 0 ),
31 | (888914, 86, 20.14 , 0 ),
32 | (901151, 83, 146 , 0 ),
33 | (910652, 83, 160 , 0 ),
34 | (923097, 86, 25.2 , 0 ),
35 | (925555, 97, 4.5 , 0 ),
36 | (933432, 86, 24.84 , 0 ),
37 | (942629, 83, 160 , 0 ),
38 | (953871, 86, 25.56 , 0 ),
39 | (961474, 83, 160 , 0 ),
40 | (970190, 86, 6.12 , 0 ),
41 | (980051, 83, 160 , 0 ),
42 | (989861, 86, 8.64 , 0 ),
43 | (999726, 83, 160 , 0 ),
44 | (1007970, 86, 5.4 , 0 ),
45 | (1016764, 83, 160 , 0 ),
46 | (1025142, 93, 6 , 0 ),
47 | (1028077, 86, 6.48 , 0.0 ),
48 | (1034160, 83, 160 , 160 ),
49 | (1045654, 86, 9.36 , 9.36 ),
50 | (1051899, 83, 160 , 0 ),
51 | (1063557, 86, 18.36 , 0 ),
52 | (1065272, 83, (-252.9) , (-200) )
53 | ]
54 |
55 | testDataPayments :: Payments
56 | testDataPayments = [
57 | (408703, 0, 113.88 , 0 ),
58 | (417630, 0, 180 , 0 ),
59 | (425139, 0, 193 , 0 ),
60 | (431755, 0, 185 , 0 ),
61 | (439355, 0, 185 , 0 ),
62 | (446878, 0, 200 , 0 ),
63 | (461092, 0, 300 , 52.88 ),
64 | (468648, 0, 180 , 150 ),
65 | (475296, 0, 170 , 160 )
66 | ]
--------------------------------------------------------------------------------
/Programs/RestCorrecting/Types.hs:
--------------------------------------------------------------------------------
1 | {-
2 | /****************************************************************************
3 | ** RestCorrecting 1.0
4 | ** Copyright (C) 2011 Granin A.S.
5 | ** Contact: Granin A.S. (graninas@gmail.com)
6 | **
7 | ** This file is part of RestCorrecting 1.0.
8 | **
9 | ** GNU General Public License Usage
10 | ** This file may be used under the terms of the GNU
11 | ** General Public License version 3.0 as published by the Free Software
12 | ** Foundation and appearing in the file LICENSE.GPL3 included in the
13 | ** packaging of this file. Please review the following information to
14 | ** ensure the GNU General Public License version 3.0 requirements will be
15 | ** met: http://www.gnu.org/licenses/gpl.html.
16 | **
17 | ** If you have questions regarding the use of this file, please contact
18 | ** author (graninas@gmail.com).
19 | **
20 | ****************************************************************************/
21 | -}
22 |
23 | module Types where
24 |
25 |
26 | data RawValue = DoubleVal Double
27 | | Int32Val Int
28 | -- | Int64Val Int
29 | deriving (Show)
30 |
31 | type RawRow = [RawValue]
32 | type RawData = [RawRow]
33 |
34 | -- (ID_RECORD, ID_USL, SUMMA, OST_REC)
35 | type Record = (Int, Int, Double, Double)
36 | type Records = [Record]
37 |
38 | type Charge = Record
39 | type Charges = Records
40 |
41 | type Payment = Record
42 | type Payments = Records
43 |
44 |
--------------------------------------------------------------------------------
/Programs/RestCorrecting/dbDataTest.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/RestCorrecting/dbDataTest.txt
--------------------------------------------------------------------------------
/Programs/RestCorrecting/id_obsh.txt:
--------------------------------------------------------------------------------
1 | 1294
2 | 1434
3 | 1510
4 | 1541
5 | 2005
6 | 2144
7 | 2261
8 | 2304
9 | 2447
10 | 2820
11 | 3622
12 | 3659
13 | 4023
14 | 4643
15 | 5138
16 | 5867
17 | 5870
18 | 6628
19 | 7191
20 | 7793
21 | 7833
22 | 7948
23 | 8001
24 | 8969
25 | 9202
26 | 9250
--------------------------------------------------------------------------------
/Programs/RestCorrecting/testResult.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/RestCorrecting/testResult.txt
--------------------------------------------------------------------------------
/Programs/RestCorrecting/updateScripts.sql:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Programs/RestCorrecting/updateScripts.sql
--------------------------------------------------------------------------------
/Programs/SimpleFormat/Process.hs:
--------------------------------------------------------------------------------
1 | module Process where
2 |
3 | import Data.List (isPrefixOf)
4 |
5 | type BorderElement = String
6 | type OpenTag = String
7 | type CloseTag = String
8 |
9 | process :: String -> BorderElement -> (OpenTag, CloseTag) -> Bool -> String
10 | process [] _ _ _ = []
11 | process xs el tags@(openT, _) True | el `isPrefixOf` xs = openT ++ process (drop (length el) xs ) el tags False
12 | process xs el tags@(_, closeT) False | el `isPrefixOf` xs = closeT ++ process (drop (length el) xs ) el tags True
13 | process (x:xs) el tags b = x : process xs el tags b
--------------------------------------------------------------------------------
/Programs/SimpleFormat/SimpleFormat.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Process
4 |
5 | italic = ["__", "", ""]
6 | blue = ["@@", "", ""]
7 | bold = ["**", "", ""]
8 | doubleBlockQuote = ["<>", "", "
"]
9 |
10 | formatters :: [[String]]
11 | formatters = [italic, blue, bold, doubleBlockQuote]
12 |
13 | format :: [String] -> String -> String
14 | format (border : openTag : closeTag : _) s = process s border (openTag, closeTag) True
15 |
16 |
17 | main :: IO ()
18 | main = do
19 | fContents <- readFile "text.txt"
20 |
21 | let result = foldr format fContents formatters
22 |
23 | writeFile "p_text.txt" result
24 | writeFile "p_text.html" result
25 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Prototypes/Adv2Game/Types.hs:
--------------------------------------------------------------------------------
1 | module Types where
2 |
3 | import qualified Data.Map as M
4 |
5 |
6 | removeProperty = undefined
7 |
8 | (|>) :: a -> a -> [a]
9 | x |> y = x : [y]
10 |
11 | (~->) :: a -> b -> (a, b)
12 | x ~-> y = (x, y)
13 |
14 | infixl 0 |>
15 | infixl 1 ~->
16 |
17 | get = undefined
18 | put = undefined
19 |
20 | setState :: Monad m => String -> m a
21 | setState = undefined
22 |
23 | delProp :: Monad m => String -> a -> m a
24 | delProp = undefined
25 |
26 | mapSubObjects = undefined
27 | enableProperty = undefined
28 |
29 | noP = undefined
30 |
31 | getProperty = undefined
32 |
33 | prop :: Monad m => a -> [(String, m a)]
34 | prop = \o -> case getProperty "lockable" o of
35 | "locked" -> "unlock" ~-> setState "unlocked" |>
36 | "break" ~-> do
37 | delProp "lockable" o
38 | mapSubObjects enableProperty o
39 | "unlocked" -> []
40 |
41 |
42 |
43 | lockable = undefined
44 | locked = undefined
45 | openable = undefined
46 | closed = undefined
47 |
48 | data Object a = Object
49 | {
50 | properties :: a
51 | }
52 |
53 | myObject = Object {properties = [lockable locked, openable closed]}
54 |
--------------------------------------------------------------------------------
/Prototypes/Adv2Game/Types2.hs:
--------------------------------------------------------------------------------
1 |
2 |
3 | data Object = Object
4 | {
5 | properties :: [Property]
6 | } deriving (Eq)
7 |
8 |
9 | data Property = Property String [(State, String)]
10 | deriving (Eq)
11 |
12 | data State = State String
13 | deriving (Eq)
14 |
15 | switch (st1, act1) (st2, act2) x | x == st2 = [(st1, act1)]
16 | | x == st1 = [(st2, act2)]
17 |
18 |
19 | opened = State "opened"
20 | closed = State "closed"
21 |
22 | openable :: State -> Property
23 | openable = Property "openable" . switch (opened, "open") (closed, "close")
24 |
25 | drawer = Object { properties = [openable opened] }
26 |
27 |
28 | propertyActions :: Property -> [String]
29 | propertyActions (Property _ xs) = foldr (\(_, act) -> (act:)) [] xs
30 |
31 | actions :: [Property] -> [String]
32 | actions = foldr (\p -> (propertyActions p ++)) []
33 |
34 |
35 | main :: IO ()
36 | main = do
37 | putStrLn "test"
38 |
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/Actions.hs:
--------------------------------------------------------------------------------
1 | module Actions where
2 |
3 | import Types
4 | import EventFlowTree
5 | import Event
6 |
7 | sendToFuture :: Int -> EventFlowTree -> Maybe EventFlowTree
8 | sendToFuture 0 tree = Nothing
9 | sendToFuture tick tree = Just $ update (tick, 'r', "SpaceShip sended to past and returned.") tree
10 |
11 |
12 | findEvent :: Char -> EventFlowTree -> Event
13 | findEvent ch tree = case lookupByEvent ch tree of
14 | Just e -> e
15 | Nothing -> emptyEvent
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/Event.hs:
--------------------------------------------------------------------------------
1 | module Event where
2 |
3 | import Types
4 |
5 | emptyEvent :: Event
6 | emptyEvent = (0, '_', [])
7 |
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/EventFlowTree.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Prototypes/BigSpace.EventFlowTree/EventFlowTree.hs
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Types
4 | import EventFlowTree
5 | import PreGen.World
6 | import Actions
7 |
8 | run :: Int -> EventFlowTree -> EventFlowTree -> IO ()
9 | run tt preGenTree tree = do
10 | putStr (show tt ++ "tt ")
11 | act <- getLine
12 | case act of
13 | "send" -> let (t, _, _) = findEvent 'r' preGenTree in
14 | case sendToFuture t tree of
15 | Just newTree -> do
16 | putStrLn "SpaceShip sended to future."
17 | run (tt + 1) preGenTree newTree
18 | Nothing -> putStrLn "No send." >> run (tt + 1) preGenTree tree
19 | _ -> run (tt + 1) preGenTree tree
20 |
21 |
22 |
23 |
24 | main :: IO ()
25 | main = do
26 | putStrLn "BigSpace"
27 |
28 | let gameSeconds = 31104000
29 | run 0 (fromTimeLine gameSeconds preGenWorldTL) $ mkEmptyTree gameSeconds
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/PreGen/World.hs:
--------------------------------------------------------------------------------
1 | module PreGen.World where
2 |
3 | import Types
4 |
5 | preGenWorldTL :: TimeLine
6 | preGenWorldTL =
7 | (0, '_', "Time begin")
8 | : (10, '_', "SpaceShip from future!")
9 | : (15, '_', "SpaceShip was damaged.")
10 | : (20, '_', "SpaceShip sended back to the future.")
11 | : (100, 'S', "SpaceShip begin")
12 | : (zip3 [101..] "paceShip" $ repeat [])
13 | ++ (
14 | (150, 'r', "SpaceShip sended to past and returned.")
15 | : (200, '_', "Time end")
16 | : []
17 | )
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/README:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Prototypes/BigSpace.EventFlowTree/README
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/Tools.hs:
--------------------------------------------------------------------------------
1 | module Tools where
2 |
3 |
4 | numberPowList :: Int -> [(Int, Int)]
5 | numberPowList n = zip [0..] $ scanl (*) 1 (repeat n)
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/Types.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Prototypes/BigSpace.EventFlowTree/Types.hs
--------------------------------------------------------------------------------
/Prototypes/BigSpace.EventFlowTree/test.txt:
--------------------------------------------------------------------------------
1 | Branch (0,3)
2 | (Branch (0,1)
3 | (Leaf (0,'_',""))
4 | (Leaf (1,'_',"")))
5 | (Branch (2,3)
6 | (Leaf (2,'F',"SS!"))
7 | (Leaf (3,'_',"")))
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/BigSpace.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Type.Types
4 | import Type.Event
5 |
6 | data WorldState a = WS
7 | {
8 | eventTree :: [Event a]
9 | }
10 | deriving (Show)
11 |
12 | zeroWorldState :: WorldState Int
13 | zeroWorldState = WS {eventTree = []}
14 |
15 |
16 |
17 | main = do
18 |
19 | x <- return zeroWorldState
20 | putStrLn "Done."
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/Type/Constants.hs:
--------------------------------------------------------------------------------
1 | module Type.Constants where
2 |
3 | import qualified Data.Word as W
4 |
5 | type GeometryScale = W.Word32
6 | type TimeScale = W.Word32
7 |
8 | geometryLocalScale1Multiplier :: GeometryScale
9 | geometryLocalScale1Multiplier = 1000000
10 |
11 | geometryLocalScale2Multiplier :: GeometryScale
12 | geometryLocalScale2Multiplier = 1000
13 |
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/Type/Event.hs:
--------------------------------------------------------------------------------
1 | module Type.Event where
2 |
3 | import Type.Types
4 | import Type.Universe
5 |
6 | import qualified Data.Foldable as F
7 | import qualified Data.Monoid as M
8 |
9 | data UniverseObject o => Event o = Event Position o
10 | deriving (Show)
11 |
12 |
13 |
14 |
15 |
16 | {-
17 |
18 | instance Functor (Entry k) where
19 | fmap f (Entry k v) = Entry k (f v)
20 |
21 | instance Foldable (Entry k) where
22 | foldMap f (Entry _ v) = f v
23 |
24 | instance Ord k => Monoid (Prio k v) where
25 | mempty = NoPrio
26 | x `mappend` NoPrio = x
27 | NoPrio `mappend` y = y
28 | x@(Prio kx _) `mappend` y@(Prio ky _)
29 | | kx <= ky = x
30 | | otherwise = y
31 |
32 | instance Ord k => Measured (Prio k v) (Entry k v) where
33 | measure (Entry k v) = Prio k v
34 |
35 | -}
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/Type/EventTree.hs:
--------------------------------------------------------------------------------
1 | module Type.EventTree where
2 |
3 | import Types.Type
4 | import Types.Event
5 |
6 | import qualified Data.FingerTree as FT
7 | import qualified Data.Foldable (Foldable(foldMap)) as F
8 |
9 | type TopHistoryMeasure = (SpaceScale, SpaceTime)
10 |
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/Type/Types.hs:
--------------------------------------------------------------------------------
1 | module Type.Types where
2 |
3 | import qualified Data.Word as W
4 |
5 | import Type.Constants
6 |
7 | data GeometryPosition = GP
8 | {
9 | gpLocal1Scale :: GeometryScale,
10 | gpLocal2Scale :: GeometryScale,
11 | gpPlanetaryScale :: GeometryScale,
12 | gpStarSystemScale :: GeometryScale
13 | }
14 | deriving (Show)
15 |
16 | data TimePosition = TP
17 | {
18 | tpLocalScale :: TimeScale,
19 | tpAgeScale :: TimeScale,
20 | tpEpochScale :: TimeScale
21 | }
22 | deriving (Show)
23 |
24 | data Position = Pos
25 | {
26 | pGeometryPosition :: GeometryPosition,
27 | pTimePosition :: TimePosition
28 | }
29 | deriving (Show)
30 |
31 | type SpaceScale = W.Word64
32 | type SpaceTime = W.Word64
33 |
34 |
35 |
--------------------------------------------------------------------------------
/Prototypes/BigSpace.FingerTreeUnstructured/Type/Universe.hs:
--------------------------------------------------------------------------------
1 | module Type.Universe where
2 |
3 | import qualified Data.Word as W
4 |
5 | class UniverseObject o where
6 | objectId :: Word32
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/Tests/.gitignore:
--------------------------------------------------------------------------------
1 |
2 | *.exe
3 | *.hi
4 | *.o
--------------------------------------------------------------------------------
/Tests/AppoxyHiringTask/Lucky.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Data.List as L
4 |
5 | withEqualConsequtives :: String -> Bool
6 | withEqualConsequtives s = any (\subS -> length subS > 1) . group $ s
7 |
8 | composeLucky :: String -> [String]
9 | composeLucky = L.nub . filter (not . withEqualConsequtives) . L.permutations
10 |
11 | howManyLuckies :: String -> Either String Int
12 | howManyLuckies s = if l >= 1 && l <= 10
13 | then Right $ length $ composeLucky s
14 | else Left "There are bounds: length should be in range [1,10]"
15 | where
16 | l = length s
17 |
18 | main = do
19 | s <- readFile "lucky.txt"
20 | print "Luckies count:"
21 | print $ howManyLuckies $ init s
22 |
--------------------------------------------------------------------------------
/Tests/AppoxyHiringTask/StringOptimization.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Data.Maybe (fromJust)
4 |
5 | difference x y | length x == length y = Just $ difference' 0 x y
6 | | otherwise = Nothing
7 | where
8 | difference' d [] [] = d
9 | difference' d (x:xs) (y:ys) | x /= y = difference' (d + 1) xs ys
10 | | otherwise = difference' d xs ys
11 |
12 |
13 | findMinSubstringPos aLength minP curP dif [] _ = minP
14 | findMinSubstringPos aLength minP curP dif _ [] = minP
15 | findMinSubstringPos aLength minP curP dif a b@(_:bs) = case difference a (take aLength b) of
16 | Just d -> if d < dif
17 | then findMinSubstringPos aLength curP (curP + 1) d a bs
18 | else findMinSubstringPos aLength minP (curP + 1) dif a bs
19 | Nothing -> minP
20 |
21 | fillFromB minIdx a b = take (minIdx - 1) b
22 | ++ a
23 | ++ drop (minIdx - 1 + length a) b
24 |
25 | optimizeStrings a b | length a == length b = difference a b
26 | | otherwise = let
27 | aLength = length a
28 | minimumIndex = findMinSubstringPos aLength 1 1 (maxBound :: Int) a b
29 | minString = fillFromB minimumIndex a b
30 | in difference minString b
31 |
32 | minimize :: String -> String -> Either String Int
33 | minimize a b | length a > length b = Left "Length of A should be less or equal than length of B."
34 | | otherwise = Right $ fromJust $ optimizeStrings a b
35 |
36 |
37 | main = do
38 | a <- readFile "a.txt"
39 | b <- readFile "b.txt"
40 | putStrLn "Minimization difference:"
41 | print $ minimize a b
42 |
--------------------------------------------------------------------------------
/Tests/AppoxyHiringTask/a.txt:
--------------------------------------------------------------------------------
1 | giorgi
2 |
--------------------------------------------------------------------------------
/Tests/AppoxyHiringTask/b.txt:
--------------------------------------------------------------------------------
1 | igroig
2 |
--------------------------------------------------------------------------------
/Tests/AppoxyHiringTask/lucky.txt:
--------------------------------------------------------------------------------
1 | abcdefghij
2 |
--------------------------------------------------------------------------------
/Tests/ArrowsAndFrees/ArrEff.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Arrows #-}
2 | module ArrEff where
3 |
4 | import Prelude hiding ((.), id)
5 | import Control.Category
6 | import Control.Arrow
7 | import Control.Monad.Free
8 |
9 | newtype ArrEff eff b c = ArrEff (b -> eff (c, ArrEff eff b c))
10 |
11 | instance Monad eff => Category (ArrEff eff) where
12 | id = ArrEff (\b -> return (b, id))
13 | ArrEff g . ArrEff f = ArrEff arrFG
14 | where
15 | arrFG a = do
16 | fa <- f a
17 | feededF fa
18 | feededF (b, arr1) = do
19 | gb <- g b
20 | feededG arr1 gb
21 | feededG arr1 (c, arr2) = return (c, arr2 . arr1)
22 |
23 | instance Monad eff => Arrow (ArrEff eff) where
24 | arr f = ArrEff (\b -> return (f b, arr f))
25 | first (ArrEff f) = ArrEff arrF
26 | where
27 | arrF (b, d) = do
28 | fb <- f b
29 | feededF fb d
30 | feededF (c, arr1) d = return ((c, d), first arr1)
31 |
32 | instance Monad eff => Functor (ArrEff eff b) where
33 | fmap f (ArrEff r) = ArrEff (\b -> do
34 | (c, next) <- r b
35 | return (f c, fmap f next))
36 |
37 | mArr mf = ArrEff (\b -> do
38 | c <- mf b
39 | return (c, mArr mf))
40 |
41 | mConst mf = ArrEff (\_ -> do
42 | c <- mf
43 | return (c, mConst mf))
44 |
45 | aConst c = arr (const c)
46 |
47 | runArrEffList :: Monad m => [c] -> ArrEff m b c -> [b] -> m [c]
48 | runArrEffList cs (ArrEff f) [] = return cs
49 | runArrEffList cs (ArrEff f) (b:bs) = do
50 | (c, next) <- f b
51 | runArrEffList (c:cs) next bs
52 |
53 | runArrEff :: Monad m => ArrEff m b c -> [b] -> m [c]
54 | runArrEff = runArrEffList []
55 |
56 | runArrEff1 :: Monad m => ArrEff m b c -> b -> m (c, ArrEff m b c)
57 | runArrEff1 (ArrEff f) b = f b
58 |
59 | timesA :: Monad m => Int -> ArrEff m b c -> ArrEff m b [c]
60 | timesA 0 _ = aConst []
61 | timesA n ar = ArrEff (\b -> do
62 | (c, next) <- runArrEff1 ar b
63 | (cs, next') <- runArrEff1 (timesA (n-1) next) b
64 | return (c:cs, next'))
65 |
66 | forEachA :: Monad m => ArrEff m b () -> ArrEff m [b] ()
67 | forEachA ar = ArrEff (\bs -> do
68 | mapM_ (runArrEff1 ar) bs
69 | return ((), aConst ()))
70 |
71 | ------ Arrow for Free language --------------------------------------------------
72 | type ArrEffFree f b c = ArrEff (Free f) b c
73 |
74 | -- :t says:
75 | -- (Monad m1, Monad m)
76 | -- => (m (c, ArrEff m b c) -> m1 (b1, t))
77 | -- -> ArrEff m b c
78 | -- -> b
79 | -- -> m1 b1
80 | runFreeArr interpret ar v = do
81 | let p = runArrEff1 ar v
82 | (c, next) <- interpret p -- TODO: what to do with next?
83 | return c
84 |
85 | --------------------- Research stuff -------------------
86 |
87 | runArrEvent :: Read b => ArrEff IO b (Bool, c) -> [c] -> IO [c]
88 | runArrEvent (ArrEff f) cs = do
89 | b <- getLine
90 | result <- f (read b)
91 | case result of
92 | ((True, c), next) -> runArrEvent next (c:cs)
93 | ((False, c), _) -> return (c:cs)
94 |
--------------------------------------------------------------------------------
/Tests/ArrowsAndFrees/ArrowsResearch.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Arrows #-}
2 |
3 | module ArrowsResearch where
4 |
5 | import Prelude hiding ((.), id)
6 | import Control.Category
7 | import Control.Arrow
8 |
9 | newtype SF b c = SF { runSF :: [b] -> [c] }
10 |
11 | instance Category SF where
12 | id = SF id
13 | SF g . SF f = SF (g . f)
14 |
15 | instance Arrow SF where
16 | arr f = SF (map f)
17 | -- http://stackoverflow.com/questions/28402932/haskell-arrow-delay-function
18 | first (SF f) = SF (unzip >>> first f >>> uncurry zip)
19 | {-
20 | first (SF f) = SF (uncurry zip . (f .*. id) . unzip)
21 | where
22 | (.*.) :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)
23 | (.*.) f g (a,c) = (f a, g c)
24 | -}
25 |
26 | delay x = SF (x:)
27 |
28 | pairPred = arr id &&& delay 0
29 |
30 | testSFArr = do
31 | print $ runSF (arr (+1)) [1..5]
32 | print $ runSF (delay 0) [1..5]
33 | print $ runSF pairPred [1..5]
34 |
35 | -----------------------------------------------------------------------------
36 |
37 | -- This is actually a stateful stream transducer.
38 | -- See http://stackoverflow.com/questions/4191424/what-are-arrows-and-how-can-i-use-them
39 | newtype MyArr b c = MyArr (b -> (c, MyArr b c))
40 |
41 | instance Category MyArr where
42 | id = MyArr (\b -> (b, id))
43 | MyArr g . MyArr f = MyArr arrFG
44 | where
45 | arrFG a = feededF (f a)
46 | feededF (b, arr1) = feededG arr1 (g b)
47 | feededG arr1 (c, arr2) = (c, arr2 . arr1)
48 |
49 | instance Arrow MyArr where
50 | arr f = MyArr (\b -> (f b, arr f))
51 | first (MyArr f) = MyArr arrF
52 | where
53 | arrF (b, d) = feededF (f b) d
54 | feededF (c, arr1) d = ((c, d), first arr1)
55 |
56 | runArrLst :: MyArr b c -> [b] -> [c]
57 | runArrLst _ [] = []
58 | runArrLst (MyArr f) (b:bs) = let (c, next) = f b
59 | in c : runArrLst next bs
60 |
61 | countA :: MyArr b Int
62 | countA = count' 0
63 | where
64 | count' n = MyArr (\_ -> (n+1, count' (n+1)))
65 |
66 | showA :: Show b => MyArr b String
67 | showA = MyArr (\b -> (show b, showA))
68 |
69 |
70 | composedA = showA . countA
71 |
72 | composedA' = proc lst -> do
73 | cnts <- countA -< lst
74 | shs <- showA -< cnts
75 | returnA -< shs
76 |
77 | testMyArr = do
78 | let charsList = ['a'..'z']
79 | let rs1 = runArrLst showA $ runArrLst countA charsList
80 | putStrLn $ show rs1
81 |
82 | let rs2 = runArrLst composedA charsList
83 | putStrLn $ show rs2
84 |
85 | let rs3 = runArrLst composedA' charsList
86 | putStrLn $ show rs3
87 |
88 | putStrLn $ show $ rs1 == rs2
89 | putStrLn $ show $ rs1 == rs3
--------------------------------------------------------------------------------
/Tests/ArrowsAndFrees/FreeIODSL.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | {-# LANGUAGE ExistentialQuantification #-}
3 | module FreeIODSL where
4 |
5 | import Control.Monad.Trans.Class (lift)
6 | import Control.Monad.Trans.Free
7 | import Control.Monad.Trans.State
8 | import Control.Monad.IO.Class
9 | import qualified Data.Map as M
10 |
11 | data Value = FloatValue Float
12 | | IntValue Int
13 | | StringValue String
14 | deriving (Show, Eq)
15 |
16 | data Property a = Get String (Value -> a)
17 | | Set String Value a
18 | deriving (Functor)
19 |
20 | type ObjectIOF a = FreeT Property IO a
21 |
22 | setP prop val = liftF (Set prop val ())
23 | getP prop = liftF (Get prop id)
24 |
25 | type Object = M.Map String Value
26 | type Interpreter a = StateT Object IO a
27 |
28 | interpretObject :: ObjectIOF a -> Interpreter a
29 | interpretObject obj = do
30 | x <- liftIO $ runFreeT obj
31 | interpretObject' x
32 |
33 | interpretObject' (Pure a) = return a
34 | interpretObject' (Free a) = interpretProperty a
35 |
36 | --interpretProperty :: Property a -> Interpreter a
37 | interpretProperty (Get prop next) = do
38 | obj <- get
39 | case M.lookup prop obj of
40 | Just v -> interpretObject (next v)
41 | Nothing -> error $ show ("No property", prop)
42 | interpretProperty (Set prop val next) = do
43 | obj <- get
44 | put $ M.insert prop val obj
45 | interpretObject next
46 |
47 | value1 = StringValue "Prop1"
48 |
49 | script :: ObjectIOF Value
50 | script = do
51 | setP "P1" value1
52 | liftIO $ putStrLn "Ho-ho!"
53 | getP "P1"
54 |
55 | test = do
56 | (v, obj) <- runStateT (interpretObject script) M.empty
57 | print $ v == value1
58 | print $ obj == (M.fromList [("P1", value1)])
--------------------------------------------------------------------------------
/Tests/ArrowsAndFrees/Hardware.hs:
--------------------------------------------------------------------------------
1 | module Hardware where
2 |
3 | import HardwareTypes
4 |
5 | import Data.IORef
6 |
7 | initBoosters = do
8 | controllerImpl <- newIORef (ControllerImpl "" Online 0 (map fromIntegral [1..]))
9 | return $ ControllerMock controllerImpl
10 |
11 | reportValue v = print ("reported: " ++ show v)
12 | storeValue v = print ("stored: " ++ show v)
13 | readTemperature (ControllerMock controllerImpl) = do
14 | ControllerImpl _ st n ts <- readIORef controllerImpl
15 | return (head ts)
16 | askStatus _ = return Online
17 | heatUpBoosters (ControllerMock controller) _ _ = do
18 | ControllerImpl _ st n ts <- readIORef controller
19 | writeIORef controller $ ControllerImpl "" st (n + 1) (drop 1 ts)
20 |
--------------------------------------------------------------------------------
/Tests/ArrowsAndFrees/HardwareTypes.hs:
--------------------------------------------------------------------------------
1 | module HardwareTypes where
2 |
3 |
4 | import Data.IORef
5 | import Data.Time
6 |
7 | type Name = String
8 | type Duration = DiffTime
9 | data Status = Online | Offline
10 | type Power = Float
11 | type Temperature = Float
12 |
13 | data ControllerImpl = ControllerImpl Name Status Int [Temperature]
14 | data Controller = ControllerMock (IORef ControllerImpl)
--------------------------------------------------------------------------------
/Tests/BinaryTreeWithKeys.hs:
--------------------------------------------------------------------------------
1 |
2 |
3 | data Tree = Leaf (Int, Int) | Branch (Int, Int) Tree Tree
4 | deriving (Show)
5 |
6 |
7 |
8 | leftBranch = \(cl, cr) ->
9 | let
10 | ll = cl
11 | lr = cl + (cr - cl) `div` 2
12 | in (ll, lr)
13 |
14 | rightBranch = \(cl, cr) ->
15 | let
16 | rl = cl + (cr - cl) `div` 2 + 1
17 | rr = cr
18 | in (rl, rr)
19 |
20 |
21 |
22 | mkTree :: Int -> (Int, Int) -> Tree
23 | mkTree 0 cur = let
24 | lb = leftBranch cur
25 | rb = rightBranch cur
26 | in Branch cur (Leaf lb) (Leaf rb)
27 | mkTree n cur = let
28 | lb = leftBranch cur
29 | rb = rightBranch cur
30 | in Branch cur (mkTree (n-1) lb) (mkTree (n-1) rb)
--------------------------------------------------------------------------------
/Tests/Combinations.hs:
--------------------------------------------------------------------------------
1 | -- http://rosettacode.org/wiki/Combinations#Haskell
2 |
3 | import Data.List (tails)
4 |
5 | comb :: Int -> [a] -> [[a]]
6 | comb 0 _ = [[]]
7 | comb m l = [x:ys | x:xs <- tails l, ys <- comb (m-1) xs]
--------------------------------------------------------------------------------
/Tests/Curring.hs:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 | apply x y = x y
5 |
6 | curringTest = apply show
7 |
8 | main = do
9 | putStrLn (curringTest 1)
10 |
11 | mul x = x * 2
--------------------------------------------------------------------------------
/Tests/Dividing.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/Dividing.hs
--------------------------------------------------------------------------------
/Tests/DoNotationTest.hs:
--------------------------------------------------------------------------------
1 | data Effect = E String Int
2 | data Cast a = C Effect (Cast a)
3 | type Capability a = Cast a -> a
4 | data Object a = O (Cast a) (Capability a)
5 |
6 | mkActor :: Capability a -> Object a -> Object a
7 | mkActor caps = \(O c1 _) -> O c1 caps
8 |
9 | takeBuff :: Int -> (Cast Int, String) -> Int
10 | takeBuff i (C (E "" eVal) _, _) = i
11 | takeBuff i (C (E eName eVal) c, buffName) | eName == buffName = takeBuff (i + eVal) (c, buffName)
12 | | otherwise = takeBuff i (c, buffName)
13 |
14 | (<~) = takeBuff
15 |
16 | ------------------------------
17 |
18 | warmable :: Capability Int
19 | warmable c = 10 <~ (c, "warm")
20 | frozenable c = 80 <~ (c, "cold")
21 |
22 | -- WTF?!! How does it work?!!!
23 | box = mkActor $ do
24 | warmable
25 | frozenable
26 |
--------------------------------------------------------------------------------
/Tests/ExprParsingTest.hs:
--------------------------------------------------------------------------------
1 | module ParsingTest where
2 |
3 | import Text.Parsec.String
4 | import Text.Parsec.Combinator
5 | import Text.Parsec.Char
6 | import Text.Parsec
7 |
8 | data OpExpr = OpExpr (Char, Int) FPExpr
9 | deriving (Show)
10 |
11 | data FPExpr = IntExpr FPExpr [OpExpr]
12 | | BrackedExpr FPExpr
13 | | Lit String
14 | deriving (Show)
15 |
16 | integer = do
17 | i <- many1 (oneOf ['0'..'9'])
18 | return $ Lit i
19 |
20 | op1 = (char '+', 5)
21 | op2 = (char '*', 4)
22 | op3 = (char '-', 5)
23 |
24 | expr = do
25 | many space
26 | i1 <- integer <|> brackedExpr
27 | exprs <- many opExpr
28 | return $ IntExpr i1 exprs
29 |
30 | op (p, priority) = do
31 | res <- p
32 | return (res, priority)
33 |
34 | opExpr = do
35 | many space
36 | oper <- op op1 <|> op op2 <|> op op3
37 | many space
38 | e <- integer <|> brackedExpr
39 | return $ OpExpr oper e
40 |
41 | brackedExpr :: GenParser Char st FPExpr
42 | brackedExpr = do
43 | e <- between (char '(') (char ')') expr
44 | return $ BrackedExpr e
45 |
46 | str1 = "3 + (2 - 1) * 5"
47 | str2 = "3"
48 | str3 = "3 + 5"
49 | str4 = "(2 - 1) * 5 * 2"
50 | str5 = "1 + 2 * 3"
51 |
52 | test = do
53 |
54 | let result1 = parse expr "" str1
55 | let result2 = parse expr "" str2
56 | let result3 = parse expr "" str3
57 | let result4 = parse expr "" str4
58 | let result5 = parse expr "" str5
59 |
60 |
61 | print result1
62 | print result2
63 | print result3
64 | print result4
65 | print result5
66 |
67 | translate result5
--------------------------------------------------------------------------------
/Tests/Fact.hs:
--------------------------------------------------------------------------------
1 | fact1 0 = 1
2 | fact1 n = fact1 (n-1) * n
3 |
4 | fact2 n | n == 0 = 1
5 | | otherwise = fact2 (n-1) * n
6 |
7 | fact3 n = case n == 0 of
8 | True -> 1
9 | False -> fact3 (n-1) * n
10 |
11 |
12 | fact4 n = case n of
13 | 0 -> 1
14 | _ -> fact4 (n-1) * n
15 |
16 | fact5 n = product [1..n]
17 |
18 | fact6 n = if n == 0
19 | then 1
20 | else n * fact5 (n-1)
--------------------------------------------------------------------------------
/Tests/FactAndFib.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Data.Word
4 |
5 | fib :: Word -> Word
6 | fib 0 = 0
7 | fib 1 = 1
8 | fib n = fib (n-1) + fib (n-2)
9 |
10 | fact :: Word -> Word
11 | fact 0 = 1
12 | fact n = fact (n-1) * n
--------------------------------------------------------------------------------
/Tests/FailureProbability/FailureProbability.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/FailureProbability/FailureProbability.hs
--------------------------------------------------------------------------------
/Tests/FailureProbability/compile.cmd:
--------------------------------------------------------------------------------
1 | del *.hi
2 | del *.o
3 | del FailureProbability.exe
4 |
5 | ghc -O2 FailureProbability.hs -rtsopts -threaded
6 |
--------------------------------------------------------------------------------
/Tests/FailureProbability/run.cmd:
--------------------------------------------------------------------------------
1 | FailureProbability.exe +RTS -K134217728 -RTS
--------------------------------------------------------------------------------
/Tests/Fib.hs:
--------------------------------------------------------------------------------
1 | fib :: Int -> Int
2 | fib 0 = 0
3 | fib 1 = 1
4 | fib n = fib (n-1) + fib (n-2)
--------------------------------------------------------------------------------
/Tests/FinanceTree.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/FinanceTree.hs
--------------------------------------------------------------------------------
/Tests/FizzBuzz.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/FizzBuzz.hs
--------------------------------------------------------------------------------
/Tests/FizzBuzz2.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | main :: IO ()
4 | main = do
5 | putStrLn "Printing FizzBuzzes..."
6 | mapM_ putStrLn fizzBuzzes
7 |
8 |
9 |
10 | fizzBuzzes :: [String]
11 | fizzBuzzes = iterateList [1..100]
12 | iterateList :: [Int] -> [String]
13 | iterateList [] = []
14 | iterateList (x : xs) = fizzBuzz x : iterateList xs
15 |
16 |
17 | fizzBuzzes' :: [String]
18 | fizzBuzzes' = accumulate' 1
19 | accumulate' :: Int -> [String]
20 | accumulate' 100 = [ fizzBuzz 100 ]
21 | accumulate' n = fizzBuzz n : accumulate' (n + 1)
22 |
23 |
24 | fizzBuzz :: Int -> String
25 | fizzBuzz x | isDivided x 15 = "FizzBuzz"
26 | | isDivided x 5 = "Buzz"
27 | | isDivided x 3 = "Fizz"
28 | | otherwise = show x
29 |
30 | fizzBuzz' :: Int -> String
31 | fizzBuzz' x = case isDivided x 15 of
32 | True -> "FizzBuzz"
33 | False -> case isDivided x 5 of
34 | True -> "Buzz"
35 | False -> case isDivided x 3 of
36 | True -> "Fizz"
37 | False -> show x
38 |
39 | isDivided :: Int -> Int -> Bool
40 | isDivided x n = (x `mod` n) == 0
--------------------------------------------------------------------------------
/Tests/FizzBuzz3.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | fizzBuzz :: Int -> String
4 |
5 | fizzBuzz x | isDivided x 15 = "FizzBuzz"
6 | | isDivided x 5 = "Buzz"
7 | | isDivided x 3 = "Fizz"
8 | | otherwise = show x
9 |
10 |
11 | isDivided :: Int -> Int -> Bool
12 | isDivided x n = (x `mod` n) == 0
13 |
14 | isDivided' :: Int -> (Int -> Bool)
15 | isDivided' x = \n -> (x `mod` n) == 0
16 |
17 | isDivided'' :: (Int -> Int -> Bool)
18 | isDivided'' = \x n -> (x `mod` n) == 0
19 |
20 | fizzBuzzes :: [String]
21 | fizzBuzzes = map fizzBuzz [1..100]
22 |
23 |
24 |
--------------------------------------------------------------------------------
/Tests/FizzBuzz4.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | main = do
4 | putStrLn "Printing FizzBuzzes..."
5 | print fizzBuzzes
6 |
7 | fizzBuzzes = map fizzBuzz [1..100]
8 |
9 | fizzBuzz x | isDivided x 15 = "FizzBuzz"
10 | | isDivided x 5 = "Buzz"
11 | | isDivided x 3 = "Fizz"
12 | | otherwise = show x
13 |
14 | isDivided x n = (x `mod` n) == 0
15 |
16 |
17 | hello :: IO ()
18 | hello = do
19 | putStrLn "What is your name?"
20 | yourName <- getLine
21 | putStr "Hello, "
22 | putStrLn (yourName ++ "!")
--------------------------------------------------------------------------------
/Tests/FizzBuzz5.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Data.Char (toLower)
4 |
5 | fizzBuzz :: Int -> String
6 | fizzBuzz x | (x `mod` 15) == 0 = "FizzBuzz"
7 | | (x `mod` 5) == 0 = "Buzz"
8 | | (x `mod` 3) == 0 = "Fizz"
9 | | otherwise = show x
10 |
11 | morseCode :: [(Char, String)]
12 | morseCode =
13 | [ ('b', "-..."), ('f', "..-."), ('i', ".."), ('u', "..-")
14 | , ('z', "--.."), ('0', "-----"), ('1', ".----"), ('2', "..---")
15 | , ('3', "...--"), ('4', "....-"), ('5', "....."), ('6', "-....")
16 | , ('7', "--..."), ('8', "---.."), ('9', "----.") ]
17 |
18 | toMorse :: Char -> String
19 | toMorse char = case lookup char morseCode of
20 | Just code -> code
21 | Nothing -> "???"
22 |
23 | morseBelt :: Int -> [String]
24 | morseBelt = map (' ' :) . map toMorse . map toLower . fizzBuzz
25 |
26 | morseFizzBuzzes :: String
27 | morseFizzBuzzes = (concat . concatMap morseBelt) [1..100]
28 |
29 | main = do
30 | putStrLn morseFizzBuzzes
31 |
32 | putStrLn helloWorld1
33 |
34 |
35 | prependSpace :: [Char] -> [Char]
36 | prependSpace = (' ':)
37 |
38 | appendWord :: Char -> [Char]
39 | appendWord = (:"World")
40 |
41 | helloWorld1 = "Hello," ++ (prependSpace "World")
42 | helloWorld2 = "Hello," ++ (appendWord ' ')
43 |
44 | hello = 'H' : 'e' : 'l' : 'l' : 'o' : []
45 |
46 | -- all these functions have type (Int -> String)
47 | toLowerFizzBuzz1 = map toLower . fizzBuzz -- eta-conversion
48 | toLowerFizzBuzz2 n = (map toLower . fizzBuzz) n
49 | toLowerFizzBuzz3 n = map toLower . fizzBuzz $ n
50 | toLowerFizzBuzz4 n = map toLower (fizzBuzz n)
51 | toLowerFizzBuzz5 n = map toLower $ fizzBuzz n
52 | toLowerFizzBuzz6 n = map toLower $ fizzBuzz $ n
53 |
54 |
--------------------------------------------------------------------------------
/Tests/FizzBuzz6Free.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 |
3 | import Control.Monad.Free
4 |
5 | data FizzBuzz a = GetFizz Int Int (String -> a)
6 | | GetBuzz Int Int (String -> a)
7 | | GetNum Int Int (String -> a)
8 | -- deriving (Functor)
9 |
10 | type FizzBuzzer a = Free FizzBuzz a
11 |
12 | instance Functor FizzBuzz where
13 | fmap f (GetFizz n m next) = GetFizz n m (fmap f next)
14 | fmap f (GetBuzz n m next) = GetBuzz n m (fmap f next)
15 | fmap f (GetNum n m next) = GetNum n m (fmap f next)
16 |
17 | getFizz, getBuzz, getNum :: Int -> Int -> FizzBuzzer String
18 | getFizz n m = liftF (GetFizz n m id)
19 | getBuzz n m = liftF (GetBuzz n m id)
20 | getNum z n = liftF (GetNum z n id)
21 |
22 |
23 | getFizz', getBuzz', getNum' :: Int -> Int -> FizzBuzzer String
24 | getFizz' n m = Free (GetFizz n m Pure)
25 | getBuzz' n m = Free (GetBuzz n m Pure)
26 | getNum' z n = Free (GetNum z n Pure)
27 |
28 | getFizzBuzz :: Int -> FizzBuzzer String
29 | getFizzBuzz n = do
30 | fizz <- getFizz n 5
31 | buzz <- getBuzz n 3
32 | let fb = fizz ++ buzz
33 | s <- getNum (length fb) n
34 | return $ s ++ fizz ++ buzz
35 |
36 | interpret :: FizzBuzzer String -> String
37 | interpret (Pure a) = a
38 | interpret (Free fb) = case fb of
39 | GetFizz n m next -> interpret $ next $ if n `mod` m == 0 then "Fizz" else ""
40 | GetBuzz n m next -> interpret $ next $ if n `mod` m == 0 then "Buzz" else ""
41 | GetNum 0 n next -> interpret $ next $ show n
42 | GetNum _ _ next -> interpret $ next $ ""
43 |
44 | main = do
45 | let fizzBuzzes = map (interpret . getFizzBuzz) [1..15]
46 | mapM_ print fizzBuzzes
47 |
--------------------------------------------------------------------------------
/Tests/Fractal/.gitignore:
--------------------------------------------------------------------------------
1 |
2 | /Programs/BlueFont/p_text.txt
3 | /Programs/BlueFont/text.txt
4 | /Exercises/output.txt
5 | /Exercises/perms2.txt
6 | /Exercises/permutations.txt
--------------------------------------------------------------------------------
/Tests/Fractal/FractalComonad.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | module FractalComonad where
3 |
4 | import Control.Comonad
5 | import Control.Applicative
6 |
7 | data Layer a = Layer a
8 | deriving (Show, Read, Eq, Functor)
9 |
10 | instance Comonad Layer where
11 | -- duplicate :: w a -> w (w a)
12 | duplicate (Layer l) = Layer (Layer l)
13 | -- extract :: w a -> a
14 | extract (Layer l) = l
15 |
16 |
17 | checkComLaws1 = (extract . duplicate $ cantorLayer) == cantorLayer
18 | checkComLaws2 = (fmap extract . duplicate $ cantorLayer) == cantorLayer
19 | checkComLaws3 = (duplicate . duplicate $ cantorLayer) == (fmap duplicate . duplicate $ cantorLayer)
20 | cLaws = [checkComLaws1, checkComLaws2, checkComLaws3]
21 |
22 | comonadCantorRule :: Layer Segments -> Segments
23 | comonadCantorRule = cantorGen . extract
24 |
25 |
26 | type Segment = (Float, Float)
27 | type Segments = [(Float, Float)]
28 |
29 | cantorRule :: Segment -> Segments
30 | cantorRule (x1, x2) = let
31 | len = x2 - x1
32 | oneThird = len / 3.0
33 | in [(x1, x1 + oneThird), (x2 - oneThird, x2)]
34 |
35 | cantorGen :: Segments -> Segments
36 | cantorGen segs = concatMap cantorRule segs
37 |
38 | fractal' :: [Segments]
39 | fractal' = iterate cantorGen [(0.0, 0.9)]
40 |
41 |
42 | cantorStartSegment x1 x2 = [(x1, x2)]
43 |
44 | cantorLayer = mkCantor 0.0 9.0
45 | mkCantor :: Float -> Float -> Layer Segments
46 | mkCantor x1 x2 = Layer $ cantorStartSegment x1 x2
47 |
48 | comonadCantorGen :: Layer Segments -> Layer Segments
49 | comonadCantorGen layer = comonadCantorRule `extend` layer
50 |
51 | fractal = iterate comonadCantorGen cantorLayer
52 |
53 | {- LYAH -}
54 | {-
55 |
56 | > class Functor w => Comonad w where
57 | > extract :: w a -> a
58 | > duplicate :: w a -> w (w a)
59 | > extend :: (w a -> b) -> w a -> w b
60 | > extend f = fmap f . duplicate
61 | > duplicate = extend id
62 |
63 | data Tree a = Empty | Node a (Tree a) (Tree a)
64 | deriving (Show)
65 |
66 | data TreeZ a = L a (Tree a)
67 | | R a (Tree a)
68 | deriving (Show)
69 |
70 | type TreeZS a = [TreeZ a]
71 | type TreeZipper a = (Tree a, TreeZS a)
72 |
73 | left, right :: TreeZipper a -> TreeZipper a
74 | left (Node x l r, bs) = (l, L x r:bs)
75 | right (Node x l r, bs) = (r, R x l:bs)
76 |
77 | type CantorTree = Tree Segment
78 | genLSegment x = Node (head $ cantorGen x) Empty Empty
79 | genRSegment x = Node (head $ tail $ cantorGen x) Empty Empty
80 | cantorLeft (Node x Empty r, bs) = (genLSegment x, L x r : bs)
81 | cantorLeft (Node x l r, bs) = (l, L x r : bs)
82 | cantorRight (Node x l Empty, bs) = (genRSegment x, R x l : bs)
83 |
84 | -}
85 |
--------------------------------------------------------------------------------
/Tests/Fractal/FractalOfFrcactals.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | module FractalComonad where
3 |
4 | import Control.Comonad
5 | import Control.Applicative
6 |
7 | data Layer a = Layer a
8 | deriving (Show, Read, Eq, Functor)
9 |
10 | instance Comonad Layer where
11 | -- duplicate :: w a -> w (w a)
12 | duplicate (Layer l) = Layer (Layer l)
13 | -- extract :: w a -> a
14 | extract (Layer l) = l
15 |
16 |
17 | checkComLaws1 = (extract . duplicate $ test) == test
18 | checkComLaws2 = (fmap extract . duplicate $ test) == test
19 | checkComLaws3 = (duplicate . duplicate $ test) == (fmap duplicate . duplicate $ test)
20 | cLaws = [checkComLaws1, checkComLaws2, checkComLaws3]
21 |
22 | comonadCantorRule :: Layer Segments -> Segments
23 | comonadCantorRule layer = --concatMap cantorRule . extract
24 | let segments = extract layer
25 | in concatMap cantorRule segments
26 |
27 |
28 | type Segment = (Float, Float)
29 | type Segments = [(Float, Float)]
30 |
31 | cantorRule :: Segment -> Segments
32 | cantorRule (x1, x2) = let
33 | len = x2 - x1
34 | oneThird = len / 3.0
35 | in [(x1, x1 + oneThird), (x2 - oneThird, x2)]
36 |
37 |
38 | cantorCustomGen :: Segments -> Segments
39 | cantorCustomGen segs = concatMap cantorRule segs
40 |
41 |
42 | cantorStartSegment x1 x2 = [(x1, x2)]
43 |
44 | test = mkCantor 0.0 9.0
45 | mkCantor :: Float -> Float -> Layer Segments
46 | mkCantor x1 x2 = Layer $ cantorStartSegment x1 x2
47 | cantorGen = (=>> comonadCantorRule)
48 | fractal = iterate cantorGen test
49 |
50 | {- LYAH -}
51 | {-
52 | data Tree a = Empty | Node a (Tree a) (Tree a)
53 | deriving (Show)
54 |
55 | data TreeZ a = L a (Tree a)
56 | | R a (Tree a)
57 | deriving (Show)
58 |
59 | type TreeZS a = [TreeZ a]
60 | type TreeZipper a = (Tree a, TreeZS a)
61 |
62 | left, right :: TreeZipper a -> TreeZipper a
63 | left (Node x l r, bs) = (l, L x r:bs)
64 | right (Node x l r, bs) = (r, R x l:bs)
65 |
66 | type CantorTree = Tree Segment
67 | genLSegment x = Node (head $ cantorGen x) Empty Empty
68 | genRSegment x = Node (head $ tail $ cantorGen x) Empty Empty
69 | cantorLeft (Node x Empty r, bs) = (genLSegment x, L x r : bs)
70 | cantorLeft (Node x l r, bs) = (l, L x r : bs)
71 | cantorRight (Node x l Empty, bs) = (genRSegment x, R x l : bs)
72 |
73 | -}
74 |
--------------------------------------------------------------------------------
/Tests/Fractal/FractalWithData.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | module FractalComonad where
3 |
4 | import Control.Comonad
5 | import Control.Applicative
6 |
7 | data Layer a = Layer a
8 | deriving (Show, Read, Eq, Functor)
9 |
10 | instance Comonad Layer where
11 | -- duplicate :: w a -> w (w a)
12 | duplicate (Layer l) = Layer (Layer l)
13 | -- extract :: w a -> a
14 | extract (Layer l) = l
15 |
16 |
17 | checkComLaws1 = (extract . duplicate $ cantorLayer) == cantorLayer
18 | checkComLaws2 = (fmap extract . duplicate $ cantorLayer) == cantorLayer
19 | checkComLaws3 = (duplicate . duplicate $ cantorLayer) == (fmap duplicate . duplicate $ cantorLayer)
20 | cLaws = [checkComLaws1, checkComLaws2, checkComLaws3]
21 |
22 | comonadCantorRule :: Layer Segments -> Segments
23 | comonadCantorRule layer = concatMap cantorRule . extract
24 | let segments = extract layer
25 | in concatMap cantorRule segments
26 |
27 |
28 | type Segment = (Float, Float)
29 | type Segments = [(Float, Float)]
30 |
31 | cantorRule :: Segment -> Segments
32 | cantorRule (x1, x2) = let
33 | len = x2 - x1
34 | oneThird = len / 3.0
35 | in [(x1, x1 + oneThird), (x2 - oneThird, x2)]
36 |
37 |
38 | cantorCustomGen :: Segments -> Segments
39 | cantorCustomGen segs = concatMap cantorRule segs
40 |
41 | fractal' :: [Segments]
42 | fractal' = iterate cantorCustomGen [(0.0, 0.9)]
43 |
44 |
45 | cantorStartSegment x1 x2 = [(x1, x2)]
46 |
47 | cantorLayer = mkCantor 0.0 9.0
48 | mkCantor :: Float -> Float -> Layer Segments
49 | mkCantor x1 x2 = Layer $ cantorStartSegment x1 x2
50 |
51 | comonadCantorGen :: Layer Segments -> Layer Segments
52 | comonadCantorGen = (=>> comonadCantorRule)
53 |
54 | fractal = iterate comonadCantorGen cantorLayer
55 |
56 | {- LYAH -}
57 | {-
58 | data Tree a = Empty | Node a (Tree a) (Tree a)
59 | deriving (Show)
60 |
61 | data TreeZ a = L a (Tree a)
62 | | R a (Tree a)
63 | deriving (Show)
64 |
65 | type TreeZS a = [TreeZ a]
66 | type TreeZipper a = (Tree a, TreeZS a)
67 |
68 | left, right :: TreeZipper a -> TreeZipper a
69 | left (Node x l r, bs) = (l, L x r:bs)
70 | right (Node x l r, bs) = (r, R x l:bs)
71 |
72 | type CantorTree = Tree Segment
73 | genLSegment x = Node (head $ cantorGen x) Empty Empty
74 | genRSegment x = Node (head $ tail $ cantorGen x) Empty Empty
75 | cantorLeft (Node x Empty r, bs) = (genLSegment x, L x r : bs)
76 | cantorLeft (Node x l r, bs) = (l, L x r : bs)
77 | cantorRight (Node x l Empty, bs) = (genRSegment x, R x l : bs)
78 |
79 | -}
80 |
--------------------------------------------------------------------------------
/Tests/GameOfLife.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import qualified Data.List as L
4 |
5 | type Cell = (Int, Int)
6 | type Shape = [Cell]
7 |
8 | tripleOscilator :: Shape
9 | tripleOscilator = [ (0, 0)
10 | , (0, 1)
11 | , (0, 2)
12 | ]
13 |
14 | glider :: Shape
15 | glider = [ (0, 0)
16 | , (1, 0)
17 | , (2, 0)
18 | , (2, 1)
19 | , (1, 2)
20 | ]
21 |
22 | shift :: Cell -> Shape -> Shape
23 | shift (dx, dy) = map (\(x, y) -> (x + dx, y + dy))
24 |
25 | (>|<) :: Shape -> Shape -> Shape
26 | sh1 >|< sh2 = L.nub (sh1 ++ sh2)
27 |
28 | iterations :: Shape -> [Shape]
29 | iterations pos = pos : iterations (step pos)
30 |
31 | neighbours8 cell cells = cells `L.intersect` (box8 cell)
32 |
33 | box8 (ax, ay) = [(x,y) | x <- range ax, y <- range ay, (ax,ay) /= (x,y)]
34 | lim n = [n - 1, n + 1]
35 | range n = [n - 1, n, n + 1]
36 |
37 | step :: Shape -> Shape
38 | step p = let
39 | next all [] = []
40 | next all cur@((aX, aY) : alives) =
41 | [(x, y) | x <- lim aX, y <- lim aY,
42 | length (neighbours8 (x, y) all) == 3]
43 | ++ (next all alives)
44 | alive all cell = length (neighbours8 cell all) `elem` [2,3]
45 | in L.nub $ filter (alive p) p ++ (next p p)
46 |
47 |
48 | whileAlive :: Shape -> [Shape]
49 | whileAlive p = let next = step p
50 | in if (next == p)
51 | then p : []
52 | else p : whileAlive next
53 |
54 |
55 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task1/FizzBuzz.hs:
--------------------------------------------------------------------------------
1 | {-
2 | Напишите программу, которая выводит на экран числа от 1 до 100.
3 | При этом вместо чисел, кратных трем, программа должна выводить
4 | слово «Fizz», а вместо чисел, кратных пяти — слово «Buzz».
5 | Если число кратно и 3, и 5, то программа должна выводить слово «FizzBuzz»
6 | -}
7 |
8 | module Main where
9 |
10 | fizzBuzz :: Int -> String
11 | fizzBuzz = undefined
12 |
13 | main = do
14 | let myFizzBuzzes = --put your solution here
15 |
16 | fbs <- readFile "FizzBuzzes.txt"
17 | if read fbs == myFizzBuzzes
18 | then putStrLn "Right."
19 | else putStrLn "Not right."
20 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task1/FizzBuzzes.txt:
--------------------------------------------------------------------------------
1 | ["1","2","Fizz","4","Buzz","Fizz","7","8","Fizz","Buzz","11","Fizz","13","14","FizzBuzz","16","17","Fizz","19","Buzz","Fizz","22","23","Fizz","Buzz","26","Fizz","28","29","FizzBuzz","31","32","Fizz","34","Buzz","Fizz","37","38","Fizz","Buzz","41","Fizz","43","44","FizzBuzz","46","47","Fizz","49","Buzz","Fizz","52","53","Fizz","Buzz","56","Fizz","58","59","FizzBuzz","61","62","Fizz","64","Buzz","Fizz","67","68","Fizz","Buzz","71","Fizz","73","74","FizzBuzz","76","77","Fizz","79","Buzz","Fizz","82","83","Fizz","Buzz","86","Fizz","88","89","FizzBuzz","91","92","Fizz","94","Buzz","Fizz","97","98","Fizz","Buzz"]
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task2/BlankSolver.hs:
--------------------------------------------------------------------------------
1 | {- Дано конечное ограниченное поле 5х5, в каждой ячейке которого имеется одна стрелка: вверх, вниз, вправо или влево.
2 | На позицию (x1, y1) помещается робот Тинк.
3 | На позицию (x2, y2) помещается роботиха Кики.
4 | Тинк движется по полю. У него и у Кики энергии хватит максимум на 10 шагов.
5 | Стрелка, на которую зашел Тинк, указывает Кики, куда ей двигаться.
6 | Если движение невозможно (за край поля выйти нельзя), Кики остается на месте.
7 |
8 | Задача: найти (любой) путь Тинка, когда роботы встречаются на одной клетке.
9 |
10 | Пример решения за 8 ходов:
11 |
12 | solutionPath :: Path
13 | solutionPath = [ ((0,0), (4,4))
14 | , ((1,0), (3,4))
15 | , ((0,0), (2,4))
16 | , ((0,1), (2,3))
17 | , ((0,0), (1,3))
18 | , ((0,1), (1,2))
19 | , ((0,2), (0,2))
20 | ]
21 | -}
22 |
23 | module BlankSolver where
24 |
25 | import TinkAndKiki
26 |
27 | solve :: Path
28 | solve = undefined
29 |
30 |
31 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task2/Solution8.txt:
--------------------------------------------------------------------------------
1 | [((0,0),(4,4)),((1,0),(3,4)),((0,0),(2,4)),((0,1),(2,3)),((0,0),(1,3)),((0,1),(1,2)),((0,2),(0,2))]
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task2/TinkAndKiki.hs:
--------------------------------------------------------------------------------
1 | module TinkAndKiki where
2 |
3 | type Arrow = Char
4 | type Field = [[Arrow]]
5 |
6 | type Position = (Int, Int)
7 | type Positions = [Position]
8 | type Dislocation = (Position, Position)
9 |
10 | type Path = [Dislocation]
11 | type Paths = [Path]
12 |
13 | u, d, l, r :: Char
14 | u = 'u'
15 | d = 'd'
16 | l = 'l'
17 | r = 'r'
18 |
19 | field :: Field
20 | field = [ [u, l, u, r, l]
21 | , [u, d, d, r, r]
22 | , [l, r, r, l, l]
23 | , [d, r, u, u, u]
24 | , [d, d, r, l, u] ]
25 |
26 | energyLimit = 10
27 |
28 | tinkStart, kikiStart :: Position
29 | tinkStart = (0, 0)
30 | kikiStart = (4, 4)
31 |
32 | startPositions :: Dislocation
33 | startPositions = (tinkStart, kikiStart)
34 |
35 |
36 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task3/Interpreter.hs:
--------------------------------------------------------------------------------
1 | module Interpreter where
2 |
3 | import Language
4 |
5 | data Result = StrResult String
6 | | IntResult Int
7 | | CharResult Char
8 | | OperationResult Operation
9 | | SequenceResult Result Result
10 | | Eval (IO ())
11 |
12 | evalMath Increment (IntResult i) = IntResult $ i + 1
13 | evalMath Decrement (IntResult i) = IntResult $ i - 1
14 | evalMath (Multiply n) (IntResult i) = IntResult $ i * n
15 | evalMath m _ = Eval $ putStr $ "Invalid argument for math " ++ show m
16 |
17 | evalGetChar (IntResult i) (StrResult str) | length str > i = CharResult (str !! i)
18 | | otherwise = Eval $ putStr $ "Index out of bounds: " ++ show i
19 | evalGetChar _ _ = Eval $ putStr "Invalid GetChar arguments."
20 |
21 | evalSCombinator (OperationResult op) r = interpret op r
22 | evalSCombinator _ _ = Eval $ putStr "Invalid operation for S combinator."
23 |
24 | -- | Interpreter
25 | interpret NoOperation _ = Eval $ putStrLn "No operation."
26 | interpret GetLength (StrResult str) = IntResult (length str)
27 | interpret GetLength (CharResult _) = Eval (putStr "Invalid operation: can't get length of char value.")
28 | interpret GetLength (IntResult i) = Eval (putStr "Invalid operation: can't get length of int value.")
29 | interpret GetLength (Eval _) = Eval (putStr "Invalid operation: can't get length of this value.")
30 | interpret GetLength (OperationResult _) = Eval (putStr "Invalid operation: can't get length of Operation value.")
31 | interpret GetLength (SequenceResult _ _) = Eval (putStr "Invalid operation: can't get length of Sequence value.")
32 |
33 | interpret (GetCharAt op) d@(StrResult str) = let
34 | idx = interpret op d
35 | in evalGetChar idx d
36 | interpret (GetCharAt _) (IntResult i) = Eval $ putStr "Invalid operation: can't extract char of int value."
37 | interpret (GetCharAt _) (CharResult i) = Eval $ putStr "Invalid operation: can't extract char of char value."
38 | interpret (GetCharAt _) (Eval _) = Eval $ putStr "Invalid operation: can't extract char of this value."
39 | interpret (GetCharAt _) (OperationResult _) = Eval $ putStr "Invalid operation: can't extract char of Operation value."
40 | interpret (GetCharAt _) (SequenceResult _ _) = Eval $ putStr "Invalid operation: can't extract char of Sequence value."
41 |
42 | interpret (ReturnString str) _ = StrResult str
43 |
44 | interpret (Sequence op1 op2) d = let
45 | res1 = interpret op1 d
46 | res2 = interpret op2 d
47 | in SequenceResult res1 res2
48 |
49 | interpret (ApplyMath math op) d = let
50 | x = interpret op d
51 | in evalMath math x
52 |
53 | interpret (Apply op2 op1) d = let
54 | res = interpret op1 d
55 | in interpret op2 res
56 |
57 | interpret (K op) _ = OperationResult op
58 | interpret I d = d
59 | interpret (S op1 op2) d = let
60 | h = interpret op1 d
61 | y = interpret op2 d
62 | in evalSCombinator h y
63 |
64 | -- | Result evaluator
65 | eval (Eval act) = act
66 | eval (IntResult i) = putStr $ show i
67 | eval (CharResult c) = putStr $ show c
68 | eval (StrResult s) = putStr s
69 | eval (OperationResult op) = putStr $ "Operation result is not finished: " ++ show op
70 | eval (SequenceResult r1 r2) = eval r1 >> eval r2
71 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task3/Language.hs:
--------------------------------------------------------------------------------
1 | module Language where
2 |
3 | data Math = Increment
4 | | Decrement
5 | | Multiply Int
6 | deriving (Show, Read)
7 |
8 | data Operation = Apply Operation Operation
9 | | GetLength
10 | | ApplyMath Math Operation
11 | | GetCharAt Operation
12 | | NoOperation
13 | | Sequence Operation Operation
14 | | ReturnString String
15 | | K Operation
16 | | S Operation Operation
17 | | I
18 | deriving (Show, Read)
19 |
20 | type Operations = [Operation]
21 |
22 | -- Apply :: op1 -> op2 -> d -> res
23 | -- Apply takes the second argument, applies to the third one,
24 | -- then applies the first argument to the previous result. It acts like so:
25 | -- Apply op2 op1 d = let
26 | -- res1 = op1 d
27 | -- res2 = op2 res
28 | -- in res2
29 |
30 | -- ApplyMath takes the second argument, applies to the third one,
31 | -- then tries to eval math equation with the previous result. It acts like so:
32 | -- ApplyMath :: Math -> op -> d -> res
33 | -- ApplyMath math op d = let
34 | -- res1 = op d
35 | -- res2 = evalMath math res1
36 | -- in res2
37 |
38 | -- GetLength :: String -> Int
39 |
40 | -- GetCharAt :: (String -> Int) -> String -> Char
41 | -- GetCharAt takes 2 arguments: some function f and string.
42 | -- GetCharAt applies f to string, which result is integer index.
43 | -- Then GetCharAt extracts a char from that string at that index.
44 |
45 | -- PrintMe :: String -> a -> b
46 | -- PrintMe ignores it's second parameter and just prints some string.
47 |
48 | -- ReturnString :: String -> a -> b
49 | -- ReturnString ignores it's second parameter, but allowes the first argument
50 | -- to use as string in computations.
51 |
52 | -- Sequence :: (String -> a) -> (String -> b) -> String -> [a, b]
53 | -- Sequence: applies both operations to the input parameter separately. Example:
54 | -- (Sequence (PrintMe "Hello, ") (PrintMe "World!")) => "Hello, World!"
55 |
56 | -- I just returns its argument as is. It acts like so:
57 | -- I x = x
58 | -- K takes 2 arguments: function and some argument.
59 | -- K ignores its second argument and returns the first one. It acts like so:
60 | -- K a b = a
61 | -- S recives 3 arguments: a, b, x. It acts like so:
62 | -- S a b x = let
63 | -- h = a x
64 | -- y = b x
65 | -- result = h y
66 | -- in result
67 | -- The last result value is result of S.
68 |
69 | -- S, K, I: http://en.wikipedia.org/wiki/SKI_combinator_calculus
70 |
--------------------------------------------------------------------------------
/Tests/HaskellSkbRii/Task3/TestInput.txt:
--------------------------------------------------------------------------------
1 | [ ReturnString "This is string."
2 | , GetCharAt GetLength
3 | , S (K (ApplyMath Decrement I)) GetLength
4 | , Sequence (ReturnString "Hello, ") (ReturnString "World!")
5 | , Apply GetLength (ReturnString "ABCD")
6 | ]
7 |
--------------------------------------------------------------------------------
/Tests/HighOrderFuncs.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 |
4 | numberList = [1, 2, 3, 4, 5]
5 |
6 | modifyList func list = map func list
7 |
8 | square x = x * x
9 | double x = 2 * x
10 | zero x = 0
11 |
12 | squares = modifyList square numberList
13 | doubles = modifyList double numberList
14 | zeros = modifyList zero numberList
--------------------------------------------------------------------------------
/Tests/InfSum.hs:
--------------------------------------------------------------------------------
1 |
2 |
3 | s = map (\x -> 1 / x^2) [1, 2..]
4 |
5 | s' = sum (take 1000000 s)
--------------------------------------------------------------------------------
/Tests/Kleisli.hs:
--------------------------------------------------------------------------------
1 | import Data.Char
2 | import Data.List
3 |
4 | -- test' :: String -> IO ()
5 | -- test' = runKleisli (Klesli purStrLn . arr (map toUpper) . Kleisli readFile)
6 |
7 | test :: String -> IO ()
8 | test = (putStrLn =<<) . fmap (map toUpper) . readFile
9 |
10 | test2 = fmap (putStrLn . map toUpper) . readFile
11 |
12 | main = test2 "LICENSE"
--------------------------------------------------------------------------------
/Tests/Language.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Language.Haskell.Parser
4 | import System
5 |
6 | main = do
7 | args <- getArgs
8 | case args of
9 | (a:_) -> do
10 | s <- readFile a
11 | let parsed = parseModule s
12 | putStrLn . show $ parsed
13 | writeFile (a ++ ".parsed.txt") (show parsed)
14 | _ -> putStrLn "Please, select a file."
15 |
--------------------------------------------------------------------------------
/Tests/Lessons/ListFold.hs:
--------------------------------------------------------------------------------
1 |
2 |
3 | sumList [] = 0
4 | sumList (x:xs) = x + sumList xs
5 |
6 | sumList' xs = foldr (+) 0 xs
7 |
8 |
--------------------------------------------------------------------------------
/Tests/Lessons/ListMap.hs:
--------------------------------------------------------------------------------
1 |
2 | import Data.Char
3 |
4 | l1 = [1, 1, 2, 3, 5]
5 |
6 | mul x n = x * n
7 | pow x n = x ^ n
8 |
9 | doubleList = map (*2) l1
10 | doubleList' = map (\x -> x * 2) l1
11 | doubleList'' = map (mul 2) l1
12 | doubleList''' = map (\x -> mul 2 x) l1
13 |
14 | squareList = map (^2) l1
15 | squareList' = map (\x -> x * x) l1
16 | squareList'' = map (\x -> pow x 2) l1
17 |
18 | powerOfTwo = map (2^) l1
19 | powerOfTwo' = map (\x -> 2 ^ x) l1
20 | powerOfTwo'' = map (pow 2) l1
21 | powerOfTwo''' = map (\x -> pow 2 x) l1
22 |
23 |
24 | upperString [] = []
25 | upperString (s:ss) = toUpper s : upperString ss
26 |
27 | upperString' ss = map toUpper ss
28 |
29 | upperString'' ss = map toUpper
--------------------------------------------------------------------------------
/Tests/Lessons/Structure.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/Lessons/Structure.txt
--------------------------------------------------------------------------------
/Tests/ListManipulation.hs:
--------------------------------------------------------------------------------
1 | import Data.List
2 | import Criterion.Main (defaultMain, bench, whnf)
3 |
4 | takeInterest :: [String] -> [Int] -> [String]
5 | takeInterest _ [] = []
6 | takeInterest ss (n:ns) = [ss !! n] ++ takeInterest ss ns
7 |
8 | collectFields :: Int -> [Int] -> [String] -> [String]
9 | collectFields _ _ [] = []
10 | collectFields idx fis (s:ss) | idx `elem` fis = s : collectFields (idx+1) fis ss
11 | collectFields idx fis (s:ss) | otherwise = collectFields (idx+1) fis ss
12 |
13 | testDataList n = replicate n "String!"
14 | testDataIndexes n = [0..n-1]
15 |
16 | iterestFunc n = takeInterest (testDataList n) (testDataIndexes n)
17 | collectFunc n = collectFields 0 (testDataIndexes n) (testDataList n)
18 |
19 | main = defaultMain [
20 | bench "takeInterest 10" $ whnf iterestFunc 10
21 | , bench "collectFields 10" $ whnf collectFunc 10
22 |
23 | , bench "takeInterest 100" $ whnf iterestFunc 100
24 | , bench "collectFields 100" $ whnf collectFunc 100
25 |
26 | , bench "takeInterest 1000" $ whnf iterestFunc 1000
27 | , bench "collectFields 1000" $ whnf collectFunc 1000
28 |
29 | , bench "takeInterest 10000" $ whnf iterestFunc 10000
30 | , bench "collectFields 10000" $ whnf collectFunc 10000
31 |
32 | , bench "takeInterest 50000" $ whnf iterestFunc 50000
33 | , bench "collectFields 50000" $ whnf collectFunc 50000
34 | ]
35 |
36 | {-
37 | Benchmark resuts (means):
38 | Items takeInterest collectFields Percent
39 | 10 17.33 36.84 52.9
40 | 100 20.58 36.84 44.1
41 | 1000 21.67 37.92 42.8
42 | 10000 21.13 36.84 42.6
43 | 50000 21.67 37.92 42.8
44 | -}
--------------------------------------------------------------------------------
/Tests/LookAndSay.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Data.List as L
4 | import Data.List.Split
5 |
6 | las :: String -> String
7 | las = concatMap (concat.map say.group) . splitOn ", "
8 | where
9 | say ss = show (length ss) ++ [head ss]
10 |
11 | lookAndSay :: [String]
12 | lookAndSay = iterate las "1"
--------------------------------------------------------------------------------
/Tests/Maybe.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import qualified Data.Map as M
4 |
5 | phonebook :: [(String, String)]
6 | phonebook =
7 | [ ("Bob", "01788 665242")
8 | , ("Fred", "01624 556442")
9 | , ("Alice", "01889 985333")
10 | , ("Jane", "01732 187565") ]
11 |
12 | type PhoneMap = M.Map String String
13 |
14 | phoneMap :: PhoneMap
15 | phoneMap = M.fromList phonebook
16 |
17 |
18 | getPhone :: String -> Maybe String
19 | getPhone name = lookup name phonebook
20 |
21 | printPhone :: Maybe String -> IO ()
22 | printPhone Nothing = putStrLn "Not found."
23 | printPhone (Just phone) = putStrLn phone
24 |
25 | evalPhone :: String -> IO ()
26 | evalPhone name = (printPhone . getPhone) name
27 | showPhone :: String -> IO ()
28 |
29 | showPhone name = printPhone $ getPhone name
30 |
31 | addPhone n p = M.insert n p phoneMap
32 | updatePhone n p = M.update (\_ -> Just p) n phoneMap
33 |
34 | main' = printPhone . getPhone $ "Alice"
35 | main'' = printPhone (getPhone "Alice")
36 | main''2 = printPhone $ getPhone "Alice"
37 | main''3 = printPhone $ getPhone $ "Alice"
38 |
39 | main''' = do
40 | putStr "Enter name: "
41 | name <- getLine
42 | printPhone (getPhone name)
43 |
44 |
45 | main'''' = do
46 | putStr "Enter name: "
47 | name <- getLine
48 | let phone = getPhone name
49 | printPhone phone
--------------------------------------------------------------------------------
/Tests/ModuleAbstraction/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 | import PathFind
3 |
4 | f a b c = a (findPath dijkstra b) c
--------------------------------------------------------------------------------
/Tests/ModuleAbstraction/PathFind.hs:
--------------------------------------------------------------------------------
1 | module PathFind (findPath, dijkstra, aStar) where
2 |
3 | import qualified PathFind.Dijkstra as D
4 | import qualified PathFind.AStar as A
5 |
6 | data FindPathAlgorithm = Dijkstra | AStar
7 |
8 | findPath Dijkstra = D.findPath
9 | findPath AStar = A.findPath
10 |
11 | dijkstra = Dijkstra
12 | aStar = AStar
--------------------------------------------------------------------------------
/Tests/ModuleAbstraction/PathFind/AStar.hs:
--------------------------------------------------------------------------------
1 | module PathFind.AStar (findPath) where
2 |
3 | findPath = undefined
--------------------------------------------------------------------------------
/Tests/ModuleAbstraction/PathFind/Dijkstra.hs:
--------------------------------------------------------------------------------
1 | module PathFind.Dijkstra (findPath) where
2 |
3 | findPath = undefined
--------------------------------------------------------------------------------
/Tests/MonadAbstraction/Language.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE UndecidableInstances,
2 | FunctionalDependencies,
3 | MultiParamTypeClasses,
4 | FlexibleInstances #-}
5 |
6 | module Language where
7 |
8 | import qualified Data.ConfigFile as CF
9 | import qualified Control.Monad.Reader as R
10 | import qualified Control.Monad.Writer as W
11 | import qualified Control.Monad.State as S
12 | import Data.Either.Utils
13 |
14 | newtype Configuration = Configuration CF.ConfigParser
15 |
16 | {-
17 |
18 | data Section = Section String
19 | data Option = Option String
20 | data Cfg = Cfg String String
21 |
22 | sect = Section
23 | opt = Option
24 |
25 | (Section s) <| (Option o) = Cfg s o
26 |
27 | getSect (Cfg s _) = s
28 | getOpt (Cfg _ o) = o
29 |
30 | type CfgEvaluator m a = Cfg -> m Configuration a
31 |
32 | getOption (Configuration cp) cfg = forceEither $ CF.get cp (getSect cfg) (getOpt cfg)
33 |
34 | option cfg = do
35 | cp <- R.ask
36 | return $ getOption cp cfg
37 |
38 | intOption = option :: CfgEvaluator Int
39 | strOption = option :: CfgEvaluator String
40 |
41 | evaluate cfg def = runMonad def cfg
42 |
43 | -}
44 |
45 | intOption = undefined
46 |
47 |
48 | loadConfiguration fileName = do
49 | conf <- CF.readfile CF.emptyCP fileName
50 | let cp = forceEither conf
51 | return ( Configuration cp {CF.optionxform = id, CF.accessfunc = CF.interpolatingAccess 10} )
52 |
53 |
54 | class (Monad m) => Abstract d m | m -> d where
55 | runAbstract :: m d -> String -> m a
56 |
57 |
58 | instance Abstract
59 | evaluate def opt = do
60 | cfg <- loadConfiguration opt
61 | return $ R.runReader def cfg
62 |
63 |
64 | instance (Error e, Monad m, MonadTask a m) => MonadTask a (ErrorT e m) where
65 | exit = lift exit
66 | yield = lift yield
67 | fork = lift . fork . runErrorT
68 | watch = lift . watch
69 | signal = lift . signal
70 |
71 |
72 | screenDef = do
73 | sw <- intOption "screenWidth"
74 | sh <- intOption "screenHeight"
75 | cd <- intOption "colorDepth"
76 | return (sw, sh, cd)
77 |
78 | main = do
79 | screenOpts <- runAbstract screenDef "Options.cfg"
80 |
81 | pretty <- R.runWriter (runAbstract screenDef "") screenOpts
82 | putStrLn pretty
83 |
84 | return ()
85 |
--------------------------------------------------------------------------------
/Tests/MonadAbstraction/StateMonad.hs:
--------------------------------------------------------------------------------
1 | module StateMonad where
2 |
3 |
--------------------------------------------------------------------------------
/Tests/Person.xml:
--------------------------------------------------------------------------------
1 |
2 | Lion
--------------------------------------------------------------------------------
/Tests/Phonebook.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 |
4 | phonebook :: [(String, String)]
5 | phonebook =
6 | [ ("Bob", "953 777-44-45")
7 | , ("Fred", "919 33-555-11")
8 | , ("Alice", "383 11111111")
9 | , ("Jane", "964 4000004") ]
10 |
11 | type PhoneBook = [(String, String)]
12 |
13 | validatePhones :: PhoneBook -> PhoneBook
14 | validatePhones pb = map validate pb
15 |
16 | validate :: (String, String) -> (String, String)
17 | validate (name, phone) = (name, "+7 " ++ phone)
--------------------------------------------------------------------------------
/Tests/RandomNums.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import System.Random
4 | import Control.Monad (when)
5 |
6 | rollDice :: (Int, Int) -> IO Int
7 | rollDice (l, r) = randomRIO (l, r)
8 |
9 | main = do
10 | putStrLn "Let dice you!"
11 | d20 <- rollDice (1, 20)
12 | putStrLn $ "Value: " ++ show d20
13 | case d20 >= 17 of
14 | True -> putStrLn "LUCKY!!"
15 | False -> putStrLn "No..."
16 |
17 | getName :: IO ()
18 | getName = do
19 | putStrLn "What is your name?"
20 | yourName <- getLine
21 | putStr "Hello, "
22 | putStrLn (yourName ++ "!")
23 |
24 | getName' =
25 | putStrLn "What is your name?"
26 | >>= \_ -> getLine
27 | >>= \yourName -> putStr "Hello, "
28 | >>= \_ -> putStrLn (yourName ++ "!")
29 |
30 |
31 | getName'' =
32 | putStrLn "What is your name?"
33 | >> getLine
34 | >>= \yourName -> putStr "Hello, "
35 | >> putStrLn (yourName ++ "!")
36 |
37 |
--------------------------------------------------------------------------------
/Tests/ReadWriteFile.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | getName :: IO String
4 | getName = do
5 | putStrLn "What is your name?"
6 | getLine
7 |
8 | writeMyName :: IO ()
9 | writeMyName = do
10 | name <- getName
11 | writeFile "myName.txt" name
12 |
13 |
--------------------------------------------------------------------------------
/Tests/Robotics/Task1.hs:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/Robotics/Task1.hs
--------------------------------------------------------------------------------
/Tests/Rogulike/ComonadEffectTest2.hs:
--------------------------------------------------------------------------------
1 | module RogueLike where
2 |
3 | data Effect = E String Int
4 | data Cast a = C Effect (Cast a)
5 | data Object a = O (Cast a) (Cast a -> a)
6 |
7 | instance Show Effect where
8 | show (E "" i) = "noEffect"
9 | show (E n i) = "(" ++ n ++ ":" ++ show i ++ ")"
10 |
11 | instance Show (Cast a) where
12 | show (C (E "" _) _) = ""
13 | show (C e c) = show e ++ " " ++ show c
14 |
15 | instance Show a => Show (Object a) where
16 | show (O c f) = show $ f c
17 |
18 | noEffect :: Effect
19 | noEffect = E "" 0
20 |
21 | noCast :: Cast a
22 | noCast = C noEffect noCast
23 |
24 | noObj = O noCast (\_ -> 0)
25 |
26 | takeBuff :: Int -> (Cast Int, String) -> Int
27 | takeBuff i (C (E "" eVal) _, _) = i
28 | takeBuff i (C (E eName eVal) c, buffName) | eName == buffName = takeBuff (i + eVal) (c, buffName)
29 | | otherwise = takeBuff i (c, buffName)
30 |
31 | (<~) = takeBuff
32 |
33 | cold = "cold"
34 | warm = "warm"
35 |
36 | eff = E
37 |
38 | coldC :: Cast a
39 | coldC = C (eff cold 1) noCast
40 |
41 | warmC :: Cast a
42 | warmC = C (eff warm 1) noCast
43 |
44 | inert :: Cast Int -> Int
45 | inert _ = 44
46 |
47 | frozenable :: Cast Int -> Int
48 | frozenable c = 100 <~ (c, "cold")
49 |
50 | warmable :: Cast Int -> Int
51 | warmable c = 10 <~ (c, "warm")
52 |
53 | box :: Object Int
54 | box = O noCast frozenable
55 |
56 | -- (Cast a) is monoid!!
57 | merge :: Cast a -> Cast a -> Cast a
58 | merge (C (E "" _) _) (C (E "" _) _) = noCast
59 | merge (C (E "" _) _) c = c
60 | merge c (C (E "" _) _) = c
61 | merge (C (E e1 i1) c1) xc@(C (E e2 i2) c2) = C (E e1 i1) (merge xc c1)
62 |
63 | cast c (O c1 f) = f (merge c1 c)
64 |
65 | castWarm :: Object a -> a
66 | castWarm = cast warmC
67 |
68 | castCold :: Object a -> a
69 | castCold = cast coldC
70 |
71 | a # f = f a
72 |
73 | mergeF f1 f2 = f1 -- TODO!!!!
74 |
75 | -- warmC :: Object a -> a
76 |
77 | -- box' # warmC' :: (Object a -> Object a)
78 | -- warmC' box' :: (Object a -> Object a)
79 | -- warmC' :: (Object a -> Object a) -> (Object a -> Object a)
80 |
81 | eff' e = \gen -> \(O c1 f1) -> gen (O (merge e c1) f1)
82 |
83 | warmC', coldC' :: (Object a -> Object a) -> (Object a -> Object a)
84 | coldC' = eff' coldC
85 | warmC' = eff' warmC
86 |
87 | -- extend :: (w a -> b) -> w a -> w b
88 | --extend :: ((Object a -> Object a) -> Object a) -> ((Object a -> Object a) -> (Object a -> Object a))
89 | extend = \genF -> \gen -> (\(O c1 f1) -> genF (\(O c2 f2) -> gen (O (merge c1 c2) (mergeF f1 f2) )) )
90 |
91 |
92 | mkActor caps = \(O c1 _) -> O c1 caps
93 |
94 | box' :: Object Int -> Object Int
95 | box' = mkActor frozenable
96 |
97 | --extract :: (Object a -> Object a) -> Object a
98 | extract gen = let (O c f) = (gen noObj) in O c f
99 |
100 | boxCasted = let
101 | caster1 = box' # warmC'
102 | caster2 = caster1 # coldC'
103 | caster3 = caster2 # coldC'
104 | in extract caster3
105 |
106 |
107 |
108 |
109 |
110 |
--------------------------------------------------------------------------------
/Tests/STM/ConcurrentSTM.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar
5 | import Control.Concurrent.STM
6 | import Control.Monad.STM
7 | import qualified Data.Map as M
8 |
9 | data Gen = Gen Int (Int -> Int)
10 |
11 | data Turn = A | B
12 | deriving (Eq, Show)
13 |
14 | twoStepGen :: Int -> Gen
15 | twoStepGen n = Gen n (\x -> x + 5)
16 |
17 | nextGenValue :: Gen -> (Int, Gen)
18 | nextGenValue (Gen n f) = let n' = f n in (n', (Gen n' f))
19 |
20 | notMe A = B
21 | notMe B = A
22 |
23 | turn 0 _ _ = return $ Right 0
24 | turn cnt me (turntv, gentv) = do
25 | v <- readTVarIO turntv
26 | if (v == me) then do
27 | g <- readTVarIO gentv
28 | let (v, g') = nextGenValue g
29 | print (me, v)
30 | atomically $ writeTVar gentv g'
31 | atomically $ writeTVar turntv (notMe me)
32 | return $ Right (cnt - 1)
33 | else
34 | return $ Left ()
35 |
36 | worker doneMV cnt me tvs = do
37 | res <- turn cnt me tvs
38 | case res of
39 | Left () -> do
40 | threadDelay 50
41 | worker doneMV cnt me tvs
42 | Right 0 -> do
43 | putMVar doneMV ()
44 | Right n -> worker doneMV n me tvs
45 |
46 | test = do
47 | doneMV1 <- newEmptyMVar
48 | doneMV2 <- newEmptyMVar
49 | turntv <- newTVarIO A
50 | gentv <- newTVarIO (twoStepGen 0)
51 |
52 | forkIO $ worker doneMV1 10 A (turntv, gentv)
53 | forkIO $ worker doneMV2 10 B (turntv, gentv)
54 |
55 | mapM_ readMVar [doneMV1, doneMV2]
56 |
57 | {-
58 | Will print:
59 |
60 | (A,5)
61 | (B,10)
62 | (A,15)
63 | (B,20)
64 | (A,25)
65 | (B,30)
66 | (A,35)
67 | (B,40)
68 | (A,45)
69 | (B,50)
70 | (A,55)
71 | (B,60)
72 | (A,65)
73 | (B,70)
74 | (A,75)
75 | (B,80)
76 | (A,85)
77 | (B,90)
78 | (A,95)
79 | (B,100)
80 | -}
81 |
--------------------------------------------------------------------------------
/Tests/STM/StmsMap.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar
5 | import Control.Concurrent.STM
6 | import Control.Monad.STM
7 | import qualified Data.Map as M
8 |
9 | data Gen = Gen Int (Int -> Int)
10 | | Gen' (Int -> Int)
11 |
12 | type Table = M.Map String (TVar Gen)
13 |
14 | twoStepGen :: Int -> Gen
15 | twoStepGen n = Gen n (\x -> x + 2)
16 |
17 | twoStepGen' :: Int -> Gen
18 | twoStepGen' n = Gen' (\x -> n + x + 2)
19 |
20 | nextGenValue :: Gen -> (Int, Gen)
21 | nextGenValue (Gen n f) = let n' = f n in (n', (Gen n' f))
22 | nextGenValue (Gen' f) = let v = f 0
23 | f' = twoStepGen' v
24 | in (v, f')
25 |
26 | rec 0 _ _ = return []
27 | rec cnt k m = case M.lookup k m of
28 | Just tv -> do
29 | g <- readTVarIO tv
30 | let (v, g') = nextGenValue g
31 | atomically $ writeTVar tv g'
32 | vs <- rec (cnt - 1) k m
33 | return $ v : vs
34 | Nothing -> error "not found."
35 |
36 | worker mv cnt k m = do
37 | vs <- rec cnt k m
38 | putMVar mv vs
39 |
40 | test = do
41 | mv1 <- newEmptyMVar
42 | mv2 <- newEmptyMVar
43 |
44 | let (v1, g1) = nextGenValue (twoStepGen 10)
45 | let (v2, g2) = nextGenValue g1
46 |
47 | let (v1', g1') = nextGenValue (twoStepGen' 11)
48 | let (v2', g2') = nextGenValue g1'
49 |
50 | print [v1, v2]
51 | print [v1', v2']
52 | -- Will print:
53 | -- [12,14]
54 | -- [13,15]
55 |
56 | t1 <- newTVarIO (twoStepGen 10)
57 | t2 <- newTVarIO (twoStepGen' 11)
58 |
59 | let m = M.fromList [ ("1", t1), ("2", t2) ]
60 |
61 | forkIO $ worker mv1 10 "1" m
62 | forkIO $ worker mv2 10 "2" m
63 |
64 | vs1 <- readMVar mv1
65 | vs2 <- readMVar mv2
66 |
67 | print vs1
68 | print vs2
69 | -- Will print:
70 | -- [12,14,16,18,20,22,24,26,28,30]
71 | -- [13,15,17,19,21,23,25,27,29,31]
72 | -- This means, both tvars are updating inside map while we haven't been updating map at all.
73 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | philosopers.cabal
3 | *~
--------------------------------------------------------------------------------
/Tests/STM/philosopers/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for philosopers
2 |
3 | ## Unreleased changes
4 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright Author name here (c) 2018
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 Author name here 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 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/README.md:
--------------------------------------------------------------------------------
1 | # philosopers
2 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Philosophers
4 |
5 | main :: IO ()
6 | main = runPhilosophers 5
7 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/package.yaml:
--------------------------------------------------------------------------------
1 | name: philosopers
2 | version: 0.1.0.0
3 | github: "githubuser/philosopers"
4 | license: BSD3
5 | author: "Author name here"
6 | maintainer: "example@example.com"
7 | copyright: "2018 Author name here"
8 |
9 | extra-source-files:
10 | - README.md
11 | - ChangeLog.md
12 |
13 | # Metadata used when publishing your package
14 | # synopsis: Short description of your package
15 | # category: Web
16 |
17 | # To avoid duplicated efforts in documentation and dealing with the
18 | # complications of embedding Haddock markup inside cabal files, it is
19 | # common to point users to the README.md file.
20 | description: Please see the README on Github at
21 |
22 | dependencies:
23 | - base >= 4.7 && < 5
24 |
25 | library:
26 | source-dirs: src
27 |
28 | executables:
29 | philosopers-exe:
30 | main: Main.hs
31 | source-dirs: app
32 | ghc-options:
33 | - -threaded
34 | - -rtsopts
35 | - -with-rtsopts=-N
36 | dependencies:
37 | - philosopers
38 |
39 | tests:
40 | philosopers-test:
41 | main: Spec.hs
42 | source-dirs: test
43 | ghc-options:
44 | - -threaded
45 | - -rtsopts
46 | - -with-rtsopts=-N
47 | dependencies:
48 | - philosopers
49 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers.hs:
--------------------------------------------------------------------------------
1 | module Philosophers where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
5 | import Control.Concurrent.STM
6 | import Control.Monad
7 | import System.Random (randomRIO)
8 |
9 | import Philosophers.Log
10 | import Philosophers.Snapshot
11 | import Philosophers.STM
12 | import Philosophers.Types
13 |
14 | mkFork :: Int -> IO TFork
15 | mkFork n = newTVarIO $ Fork (show n) Free
16 |
17 | mkPhilosoper :: (Int, TForkPair) -> IO Philosopher
18 | mkPhilosoper (n, tFs) = do
19 | tAct <- newTVarIO Thinking
20 | tCycles <- newTVarIO 0
21 | pure $ Philosopher (show n) tCycles tAct tFs
22 |
23 | mkCycledPairs :: [TFork] -> [TForkPair]
24 | mkCycledPairs [] = error "No elems"
25 | mkCycledPairs [_] = error "Only 1 elem"
26 | mkCycledPairs fs = map mkPair pairIndexes
27 | where
28 | pairIndexes :: [(Int, Int)]
29 | pairIndexes = [(x, x + 1) | x <- [0..length fs - 2]] ++ [(length fs - 1, 0)]
30 | mkPair :: (Int, Int) -> TForkPair
31 | mkPair (i1, i2) = (fs !! i1, fs !! i2)
32 |
33 | monitoringWorker :: LogLock -> Snapshot -> [Philosopher] -> IO ()
34 | monitoringWorker logLock s@(ss, n) ps = do
35 | threadDelay $ 1000 * 1000
36 | snapshot <- takeSnapshot (n + 1) ps
37 | if s /= snapshot
38 | then do
39 | printSnapshot logLock s
40 | monitoringWorker logLock snapshot ps
41 | else monitoringWorker logLock s ps
42 |
43 | philosopherWorker :: LogLock -> Philosopher -> IO ()
44 | philosopherWorker logLock p@(Philosopher n _ tAct _) = do
45 | t1 <- randomRIO (1, 5)
46 | t2 <- randomRIO (1, 5)
47 | let activity1Time = 1000 * 1000 * t1
48 | let activity2Time = 1000 * 1000 * t2
49 |
50 | c <- atomically $ incrementCycles p
51 | logMsg logLock $ "-- Philosopher " ++ show n ++ " next cycle: " ++ show c
52 |
53 | act1 <- atomically $ changeActivity p
54 | logMsg logLock $ "-- Philosopher " ++ show n ++ " changed activity to: " ++ show act1 ++ " for " ++ show t1 ++ " secs."
55 | threadDelay activity1Time
56 |
57 | act2 <- atomically $ changeActivity p
58 | logMsg logLock $ "-- Philosopher " ++ show n ++ " changed activity to: " ++ show act2 ++ " for " ++ show t2 ++ " secs."
59 | threadDelay activity2Time
60 |
61 | philosopherWorker logLock p
62 |
63 | runPhilosopherTread :: LogLock -> Philosopher -> IO ()
64 | runPhilosopherTread logLock ps = void $ forkIO (philosopherWorker logLock ps)
65 |
66 | runPhilosophers :: Int -> IO ()
67 | runPhilosophers count = do
68 |
69 | forks <- sequence $ take count (map mkFork [1..])
70 | let forkPairs = mkCycledPairs forks
71 | ps <- mapM mkPhilosoper (zip [1..] forkPairs)
72 |
73 | logLock <- newMVar ()
74 |
75 | s@(ss, _) <- takeSnapshot 0 ps
76 | printSnapshot logLock s
77 |
78 | _ <- forkIO (monitoringWorker logLock (ss, 1) ps)
79 | mapM_ (runPhilosopherTread logLock) ps
80 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers/Log.hs:
--------------------------------------------------------------------------------
1 | module Philosophers.Log where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
5 | import Control.Monad
6 |
7 | type LogLock = MVar ()
8 |
9 | logMsg :: LogLock -> String -> IO ()
10 | logMsg logLock msg = do
11 | _ <- takeMVar logLock
12 | putStrLn msg
13 | putMVar logLock ()
14 |
15 | acquire :: LogLock -> IO ()
16 | acquire l = void $ takeMVar l
17 |
18 | release :: LogLock -> IO ()
19 | release l = putMVar l ()
20 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers/STM.hs:
--------------------------------------------------------------------------------
1 | module Philosophers.STM where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
5 | import Control.Concurrent.STM
6 | import Control.Monad
7 | import System.Random (randomRIO)
8 |
9 | import Philosophers.Types
10 |
11 | readForks :: TForkPair -> STM (Fork, Fork)
12 | readForks (l, r) = (,) <$> readTVar l <*> readTVar r
13 |
14 | takeFork :: TFork -> STM Bool
15 | takeFork tFork = do
16 | Fork n st <- readTVar tFork
17 | case st of
18 | Taken -> pure False
19 | Free -> do
20 | modifyTVar' tFork (\(Fork n st) -> Fork n Taken)
21 | pure True
22 |
23 | takeForks :: TForkPair -> STM Bool
24 | takeForks (left, right) = do
25 | leftTaken <- takeFork left
26 | rightTaken <- takeFork right
27 | pure $ leftTaken && rightTaken
28 |
29 | -- N.B., Someone can "put" foreign fork.
30 | putFork :: TFork -> STM ()
31 | putFork tFork = modifyTVar' tFork (\(Fork n st) -> Fork n Free)
32 |
33 | putForks :: TForkPair -> STM ()
34 | putForks (left, right) = do
35 | putFork left
36 | putFork right
37 |
38 | changeActivity :: Philosopher -> STM Activity
39 | changeActivity (Philosopher n tC tAct tFs) = do
40 | act <- readTVar tAct
41 | case act of
42 | Thinking -> do
43 | taken <- takeForks tFs
44 | unless taken retry -- Do not need to put forks if any was taken!
45 | writeTVar tAct Eating
46 | pure Eating
47 | Eating -> do
48 | putForks tFs
49 | writeTVar tAct Thinking
50 | pure Thinking
51 |
52 | incrementCycles :: Philosopher -> STM Int
53 | incrementCycles (Philosopher _ tCycles _ _) = do
54 | modifyTVar' tCycles (+1)
55 | readTVar tCycles
56 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers/Snapshot.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DuplicateRecordFields #-}
2 | module Philosophers.Snapshot where
3 |
4 | import Control.Concurrent
5 | import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
6 | import Control.Concurrent.STM
7 | import Control.Monad
8 |
9 | import Philosophers.Log
10 | import Philosophers.STM
11 | import Philosophers.Types
12 |
13 | data Shot = Shot
14 | { name :: String
15 | , cycles :: Int
16 | , activity :: Activity
17 | , forks :: (Fork, Fork)
18 | }
19 | deriving Eq
20 |
21 | type Snapshot = ([Shot], Int)
22 |
23 | takeShot :: Philosopher -> STM Shot
24 | takeShot (Philosopher n tC tAct tFs) = do
25 | c <- readTVar tC
26 | act <- readTVar tAct
27 | fs <- readForks tFs
28 | pure $ Shot n c act fs
29 |
30 | takeSnapshot :: Int -> [Philosopher] -> IO Snapshot
31 | takeSnapshot n ps = (,) <$> atomically (mapM takeShot ps) <*> pure n
32 |
33 | printShot :: Shot -> IO ()
34 | printShot (Shot n c act fs) = putStrLn $ " [" ++ n ++ "] (" ++ show c ++ ") " ++ show act ++ ", " ++ show fs
35 |
36 | printSnapshot :: LogLock -> Snapshot -> IO ()
37 | printSnapshot logLock (s, n) = do
38 | acquire logLock
39 | putStrLn $ "Snapshot #" ++ show n ++ ":"
40 | mapM_ printShot s
41 | release logLock
42 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers/Types.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DuplicateRecordFields #-}
2 |
3 | module Philosophers.Types where
4 |
5 | import Control.Concurrent
6 | import Control.Concurrent.STM
7 | import Control.Monad
8 |
9 |
10 | data ForkState = Free | Taken
11 | deriving (Show, Eq)
12 |
13 | data Fork = Fork String ForkState
14 | deriving (Show, Eq)
15 |
16 | data Activity = Thinking | Eating
17 | deriving (Show, Eq)
18 |
19 |
20 | type TFork = TVar Fork
21 | type TForkPair = (TFork, TFork)
22 |
23 | -- TODO: With this data structure, philosopher can "put" foreign fork.
24 | -- Forks should be peronalized.
25 |
26 | data Philosopher = Philosopher
27 | { name :: String
28 | , cycles :: TVar Int
29 | , activity :: TVar Activity
30 | , forks :: TForkPair
31 | }
32 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/src/Philosophers2/STM.hs:
--------------------------------------------------------------------------------
1 | module Philosophers2.STM where
2 |
3 | import Control.Concurrent
4 | import Control.Concurrent.MVar (MVar, newMVar, putMVar, takeMVar)
5 | import Control.Concurrent.STM
6 | import Control.Monad
7 | import System.Random (randomRIO)
8 |
9 | data ForkState = Free | Taken
10 | deriving (Eq, Show)
11 |
12 | type TFork = TVar ForkState
13 |
14 | data Forks = Forks
15 | { fork1 :: TFork
16 | , fork2 :: TFork
17 | , fork3 :: TFork
18 | , fork4 :: TFork
19 | , fork5 :: TFork
20 | }
21 |
22 | takeFork :: TFork -> STM Bool
23 | takeFork tFork = do
24 | forkState <- readTVar tFork
25 | when (forkState == Free) (writeTVar tFork Taken)
26 | pure (forkState == Free)
27 |
28 | takeForks' :: (TFork, TFork) -> STM Bool
29 | takeForks' (tLeftFork, tRightFork) = do
30 | leftTaken <- takeFork tLeftFork
31 | rightTaken <- takeFork tRightFork
32 | pure (leftTaken && rightTaken)
33 |
34 |
35 | takeForks :: (TFork, TFork) -> STM ()
36 | takeForks (tLeftFork, tRightFork) = do
37 | leftTaken <- takeFork tLeftFork
38 | rightTaken <- takeFork tRightFork
39 | when (not leftTaken || not rightTaken) retry
40 |
41 |
42 | data PhilosopherState = Thinking | Eating
43 |
44 | data Philosopher = Philosopher
45 | { pState :: TVar PhilosopherState
46 | , pLeftFork :: TFork
47 | , pRrightFork :: TFork
48 | }
49 |
50 | changePhilosopherActivity :: Philosopher -> STM ()
51 | changePhilosopherActivity (Philosopher tState tLeftFork tRightFork) = do
52 | state <- readTVar tState
53 | case state of
54 | Thinking -> error "Changing state from Thinking not implemented."
55 | Eating -> do
56 | takeForks (tLeftFork, tRightFork)
57 | writeTVar tState Eating
58 |
59 | philosoperWorker :: Philosopher -> IO ()
60 | philosoperWorker philosopher = do
61 | atomically (changePhilosopherActivity philosopher)
62 | threadDelay 5000
63 | philosoperWorker philosopher
64 |
65 | runPhilosophers :: IO ()
66 | runPhilosophers = do
67 | tState1 <- newTVarIO Thinking
68 | tState2 <- newTVarIO Thinking
69 | tFork1 <- newTVarIO Free
70 | tFork2 <- newTVarIO Free
71 |
72 | forkIO (philosoperWorker (Philosopher tState1 tFork1 tFork2))
73 | forkIO (philosoperWorker (Philosopher tState2 tFork2 tFork1))
74 |
75 | threadDelay 100000
76 |
--------------------------------------------------------------------------------
/Tests/STM/philosopers/stack.yaml:
--------------------------------------------------------------------------------
1 | # This file was automatically generated by 'stack init'
2 | #
3 | # Some commonly used options have been documented as comments in this file.
4 | # For advanced use and comprehensive documentation of the format, please see:
5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
6 |
7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
8 | # A snapshot resolver dictates the compiler version and the set of packages
9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | # name: custom-snapshot
17 | # location: "./custom-snapshot.yaml"
18 | resolver: lts-10.4
19 |
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | # git: https://github.com/commercialhaskell/stack.git
28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | # extra-dep: true
31 | # subdirs:
32 | # - auto-update
33 | # - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - .
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | # extra-deps: []
43 |
44 | # Override default flag values for local packages and extra-deps
45 | # flags: {}
46 |
47 | # Extra package databases containing global packages
48 | # extra-package-dbs: []
49 |
50 | # Control whether we use the GHC we find on the path
51 | # system-ghc: true
52 | #
53 | # Require a specific version of stack, using version ranges
54 | # require-stack-version: -any # Default
55 | # require-stack-version: ">=1.6"
56 | #
57 | # Override the architecture used by stack, especially useful on Windows
58 | # arch: i386
59 | # arch: x86_64
60 | #
61 | # Extra directories used by stack for building
62 | # extra-include-dirs: [/path/to/dir]
63 | # extra-lib-dirs: [/path/to/dir]
64 | #
65 | # Allow a newer minor version of GHC than the snapshot specifies
66 | # compiler-check: newer-minor
--------------------------------------------------------------------------------
/Tests/STM/philosopers/test/Spec.hs:
--------------------------------------------------------------------------------
1 | main :: IO ()
2 | main = putStrLn "Test suite not yet implemented"
3 |
--------------------------------------------------------------------------------
/Tests/STree.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | data STree a
4 | = Tip
5 | | Node (STree a) a (STree a)
6 | deriving (Eq, Show, Read)
7 |
8 | main = do
9 | let strTree = show myTree
10 | writeFile "tree.txt" strTree
11 | fileContent <- readFile "tree.txt"
12 | let readedTree = read fileContent
13 | print . height $ readedTree
14 |
15 | type IntSTree = STree Int
16 |
17 | myTree, left, right :: IntSTree
18 |
19 | myTree = Node left 5 right
20 |
21 |
22 | left = Node subLeft 3 subRight
23 | right = Node Tip 7 Tip
24 |
25 | subLeft, subRight :: IntSTree
26 | subLeft = Node Tip 1 Tip
27 | subRight = Node Tip 4 Tip
28 |
29 | height :: IntSTree -> Int
30 | height Tip = 0
31 | height (Node left _ right) = 1 + subHeight
32 | where
33 | subHeight = max (height left) (height right)
34 |
35 | compare :: STree Int -> STree Int -> Bool
36 | compare t1 t2 = t1 == t2
37 |
38 | nodeWeight :: IntSTree -> (Int, Int)
39 | nodeWeight Tip = (0, 0)
40 | nodeWeight (Node l val r) = let
41 | (_, lWeight) = nodeWeight l
42 | (_, rWeight) = nodeWeight r
43 | in (val, val + lWeight + rWeight)
44 |
45 | class Show a where
46 | show :: a -> String
47 |
48 | class Read a where
49 | readsPrec :: Int -> ReadS a
50 | readList :: ReadS [a]
51 | readPrec :: ReadPrec a
52 | readListPrec :: ReadPrec [a]
53 |
54 | read :: Read a => String -> a
--------------------------------------------------------------------------------
/Tests/SizeTreap.hs:
--------------------------------------------------------------------------------
1 | module SizeTreap where
2 |
3 | import Data.Tree.Treap
4 |
5 | testData :: [(Int, Int, Int)]
6 | testData = [(1, 2, 1), (3, 6, 1), (6, 44, 1), (7, 0, 1), (2, 85, 1), (4, -2, 1), (5, 4, 1), (8, 21, 1)]
7 |
8 | sizeOf :: (Ord a, Enum a, Ord b) => Treap a b Int -> Int
9 | sizeOf Leaf = 0
10 | sizeOf (Branch _ _ v _ _) = v
11 |
12 | recalcSize :: (Ord a, Enum a, Ord b) => RecalcFunc a b Int
13 | recalcSize l r = sizeOf l + sizeOf r + 1
14 |
15 | kthElement :: (Ord a, Enum a, Ord b) => Int -> Treap a b Int -> Maybe (a, b, Int)
16 | kthElement k Leaf = Nothing
17 | kthElement k (Branch k1 p1 v1 l r) | sizeLeft == k = Just (k1, p1, v1)
18 | | sizeLeft > k = kthElement k l
19 | | sizeLeft < k = kthElement (k - sizeLeft - 1) r
20 | where sizeLeft = (sizeOf l)
21 |
22 | fromList' :: (Ord a, Enum a, Ord b) => [(a, b, Int)] -> Treap a b Int
23 | fromList' = foldr (insert recalcSize) Leaf
--------------------------------------------------------------------------------
/Tests/SlyPercents.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | percent :: Float -> Float -> ([Float], Float) -> ([Float], Float)
4 | percent p bound (partResList, num) | num > bound =
5 | let
6 | newNum = num - (num * p)
7 | newResList = partResList ++ [newNum]
8 | in percent p bound (newResList, newNum)
9 |
10 | percent _ _ res | otherwise = res
11 |
12 | exerciseData :: [(Float, Float, Float)]
13 | exerciseData = [(0.1, 500000.0, 99.0),
14 | (0.05, 400000.0, 99.0),
15 | (0.1, 250.0, 1.0),
16 | (0.05, 250.0, 1.0)]
17 |
18 | resFileName = "SlyPercents.txt"
19 |
20 |
21 | eval :: (Float, Float, Float) -> ([Float], Float)
22 | eval (p, num, bound) = percent p bound ([num], num)
23 |
24 | main = do
25 | writeFile resFileName ""
26 | let results = map eval exerciseData
27 | appendFile resFileName (show results)
28 |
29 | putStrLn "Done."
--------------------------------------------------------------------------------
/Tests/StateInjection/StateInjectionTest.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 |
3 | module Main where
4 |
5 | import Test.QuickCheck
6 | import Test.QuickCheck.All
7 |
8 | import Control.Monad.State
9 | import Control.Monad
10 | import System.Random
11 |
12 | data Context = Context { ctxNextId1 :: State Context Int
13 | , ctxNextId2 :: State Context Int }
14 |
15 |
16 | -- Client code. Knows nothing about random gens, but uses external state.
17 | getNextId1 = get >>= ctxNextId1
18 | getNextId2 = get >>= ctxNextId2
19 |
20 | worker :: State Context [Int]
21 | worker = do
22 | n1 <- getNextId1
23 | n2 <- getNextId1
24 | n3 <- getNextId2
25 | n4 <- getNextId2
26 | return [n1, n2, n3, n4]
27 |
28 |
29 | -- The state, which will be injected into client code.
30 | nextId :: Int -> State Context Int
31 | nextId prevId = do let nId = prevId + 1
32 | ctx <- get
33 | put $ ctx { ctxNextId1 = nextId nId
34 | , ctxNextId2 = nextId nId
35 | }
36 | return nId
37 |
38 | nextRnd :: StdGen -> State Context Int
39 | nextRnd prevG = do let (r, g) = random prevG
40 | ctx <- get
41 | put $ ctx { ctxNextId1 = nextRnd g
42 | , ctxNextId2 = nextRnd g
43 | }
44 | return r
45 |
46 |
47 |
48 | tests :: IO Bool
49 | tests = $quickCheckAll
50 |
51 | runTests = tests >>= \passed -> putStrLn $
52 | if passed then "All tests passed."
53 | else "Some tests failed."
54 |
55 | main :: IO ()
56 | main = do
57 | print "Just increment:"
58 | let nextIdF = nextId 0
59 | print $ evalState worker (Context nextIdF nextIdF)
60 |
61 | print "Random Id:"
62 | let g = mkStdGen 100
63 | let nextRndF = nextRnd g
64 | print $ evalState worker (Context nextRndF nextRndF)
--------------------------------------------------------------------------------
/Tests/StateInjection/StateInjectionTest2.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Control.Monad.State
4 | import Control.Monad
5 | import System.Random
6 |
7 | type Name = String
8 | data Context = Context { ctxNextId :: State Context Int
9 | , ctxNextName :: State Context Name }
10 |
11 | getNextId = get >>= ctxNextId
12 | getNextName = get >>= ctxNextName
13 |
14 |
15 | -- The state, which will be injected into client code.
16 | -- You can use nextId to provide sequental int numbers.
17 | nextId :: Int -> State Context Int
18 | nextId prevId = do let nId = prevId + 1
19 | modify (\ctx -> ctx { ctxNextId = nextId nId })
20 | return nId
21 |
22 | -- Or, instead of nextId, you can use nextRnd to provide random int numbers.
23 | nextRnd :: StdGen -> State Context Int
24 | nextRnd prevG = do let (r, g) = randomR (0, 100) prevG
25 | modify (\ctx -> ctx { ctxNextId = nextRnd g })
26 | return r
27 |
28 | -- And you can use nextName to provide some names.
29 | nextName :: Int -> State Context Name
30 | nextName 0 = do
31 | modify (\ctx -> ctx { ctxNextName = nextName 1 } )
32 | return "GNVOERK"
33 | nextName 1 = do
34 | modify (\ctx -> ctx { ctxNextName = nextName 2 } )
35 | return "RIKTIG YOGLA"
36 | nextName _ = return "BLABLABLATOR"
37 |
38 |
39 | -- Client code. Knows nothing about furniture materials, but uses external state to create it.
40 | type IkeaFurniture = (Int, Name)
41 |
42 | createFurniture :: State Context IkeaFurniture
43 | createFurniture = liftM2 (,) getNextId getNextName
44 |
45 | ikea :: State Context [IkeaFurniture]
46 | ikea = do
47 | table <- createFurniture
48 | shelf <- createFurniture
49 | return [table, shelf]
50 |
51 | main :: IO ()
52 | main = do
53 | print "Sequental ids:"
54 | print $ evalState ikea (Context (nextId 0) (nextName 0))
55 |
56 | print "Random ids:"
57 | print $ evalState ikea (Context (nextRnd (mkStdGen 100)) (nextName 0))
58 |
59 |
--------------------------------------------------------------------------------
/Tests/StateTest.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE PackageImports #-}
2 |
3 | module Main where
4 |
5 | import "mtl" Control.Monad.State.Lazy
6 |
7 |
8 | myFunc :: State Int Int
9 | myFunc = do
10 | val <- get
11 | put (val - 8)
12 | get
13 |
14 | getNumber = evalState myFunc 50
15 | main = print getNumber
--------------------------------------------------------------------------------
/Tests/StateTransformerTest.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE PackageImports #-}
2 |
3 | module Main where
4 |
5 | import "mtl" Control.Monad.State.Lazy
6 | import "mtl" Control.Monad (when)
7 |
8 | rollDice :: (Int, Int) -> IO Int
9 | rollDice (l, r) = randomRIO (l, r)
10 |
11 |
12 |
13 | data Player = Player { name :: String
14 | , awards :: [Maybe String] }
15 |
16 | data GameData = GameData
17 |
18 | { totalScore :: Int,
19 | turn :: Int,
20 | players :: [Player] }
21 |
22 | type GS a = (StateT GameData IO a)
23 |
24 |
25 | main = do
26 | putStrLn "Let dice you!"
27 | d20 <- rollDice (1, 20)
28 | putStrLn $ "Value: " ++ show d20
29 | case d20 >= 17 of
30 | True -> putStrLn "LUCKY!!"
31 | False -> putStrLn "No..."
32 |
33 |
34 | type Locations = M.Map Room Location
35 | type MaybeLocation = MaybeSomething Location
36 |
37 | data GameState = GameState {
38 | gsLocations :: Locations,
39 | gsCurrentRoom :: Room,
40 | gsObjects :: Objects
41 | } deriving (Show, Read)
42 |
43 | type GS a = (StateT GameState IO a)
44 |
45 |
46 | -- the type of an 'action' (weld, dunk, etc.)
47 | type GameAction = Object -> Object -> GameState Result
48 |
49 |
50 | data GS = GS { worldMap :: [Location]
51 | , currentLocation :: Location
52 | , welded :: Bool
53 | , bucketFull :: Bool }
54 | deriving (Show)
55 |
56 | newtype GameState a = GameState
57 | { runGameState :: StateT GS IO a }
58 | deriving (Monad, MonadIO, MonadState GS)
--------------------------------------------------------------------------------
/Tests/StateTransformerTest2.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import System.Random
4 | import Control.Monad.State (get, gets, StateT(..), evalStateT,
5 | put, MonadState(..), liftIO)
6 |
7 | data Player = Player { name :: String
8 | , awards :: [Maybe String] }
9 |
10 | data GameData = GameData
11 | { totalScore :: Int,
12 | try :: Int,
13 | players :: [Player] }
14 |
15 | type GS a = (StateT GameData IO a)
16 |
17 | getAward 20 = Just "Awesome!!!"
18 | getAward 19 = Just "Great!"
19 | getAward n | n > 16 = Just "Very well."
20 | getAward _ = Nothing
21 |
22 | turn :: Int -> GS (Maybe String)
23 | turn player = do
24 | dice <- liftIO $ randomRIO (1, 20) :: IO Int
25 | let award = getAward dice
26 | putStrLn $ "Award: " ++ show award
27 |
28 | (GameData score try players) <- get
29 | put (GameData score (try + 1) players)
30 | return award
--------------------------------------------------------------------------------
/Tests/StringManipulation.hs:
--------------------------------------------------------------------------------
1 | import Data.List
2 | import Data.String.Utils
3 | import Criterion.Main (defaultMain, bench, whnf)
4 |
5 | testUnlines n = unlines . take n $ (repeat "klsdfldskfjdks")
6 | testIntercalate n = intercalate "\n\r" . take n $ (repeat "klsdfldskfjdks")
7 |
8 | main = defaultMain [
9 | bench "testUnlines 10" $ whnf testUnlines (10)
10 | , bench "testIntercalate 10" $ whnf testIntercalate (10)
11 | , bench "testUnlines 100" $ whnf testUnlines (100)
12 | , bench "testIntercalate 100" $ whnf testIntercalate (100)
13 | , bench "testUnlines 1000" $ whnf testUnlines (1000)
14 | , bench "testIntercalate 1000" $ whnf testIntercalate (1000)
15 | , bench "testUnlines 10000" $ whnf testUnlines (10000)
16 | , bench "testIntercalate 10000" $ whnf testIntercalate (10000)
17 | , bench "testUnlines 50000" $ whnf testUnlines (50000)
18 | , bench "testIntercalate 50000" $ whnf testIntercalate (50000)
19 | , bench "testUnlines 100000" $ whnf testUnlines (100000)
20 | , bench "testIntercalate 100000" $ whnf testIntercalate (100000)
21 | , bench "testUnlines 200000" $ whnf testUnlines (200000)
22 | , bench "testIntercalate 200000" $ whnf testIntercalate (200000)
23 | ]
24 |
25 | {-
26 | Benchmark resuts (means):
27 | Items testUnlines testIntercalate Percent
28 | 10 23.84 34.05 29.9
29 | 100 22.70 34.62 34.4
30 | 1000 23.28 35.48 34.3
31 | 10000 22.17 35.48 37.5
32 | 50000 22.13 33.26 33.4
33 | 100000 21.06 35.47 40.6
34 | 200000 22.70 34.05 33.3
35 | -}
--------------------------------------------------------------------------------
/Tests/TH/WiseConstructor.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 |
3 | module WiseConstructor where
4 |
5 |
6 | import WiseConstructorTH
7 |
8 |
9 | data ADT = Zero
10 | | One Char
11 | | Two Int String
12 |
13 |
14 | mkMapper "mapper" "" ''ADT
15 |
16 | zero = undefined
17 | one = undefined
18 | two = undefined
19 |
20 |
21 | -- target functions:
22 | -- mapper (Zero) = zeroCall
23 | -- mapper (One x1) = oneCall x1
24 | -- mapper (Two x1 x2) = twoCall x1 x2
25 |
26 | {-
27 |
28 | toHttpMethod (SearchDialogs q) = Vk.searchDialogs q
29 | toHttpMethod (Authorize appId permissions) = Vk.authorization appId permissions
30 | toHttpMethod (GetHistory offset msgCount userId chatId startMessageId rev) =
31 | Vk.getHistory offset msgCount userId chatId startMessageId rev
32 |
33 | -}
34 |
--------------------------------------------------------------------------------
/Tests/TH/WiseConstructorTH.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TemplateHaskell #-}
2 |
3 | module WiseConstructorTH where
4 |
5 | import Language.Haskell.TH
6 | import Language.Haskell.TH.Syntax
7 | import Data.Traversable (traverse)
8 | import Data.Char (toLower)
9 |
10 | traceQ p x = do
11 | runIO $ putStr p
12 | runIO $ print x
13 |
14 | ptraceQ x = runIO $ putStrLn $ pprint x
15 |
16 | mkMapper :: String -> String -> Name -> Q [Dec]
17 | mkMapper mapperName mappedQualificator typeName = do
18 | clauses <- reify typeName >>= (mkMapAll mappedQualificator)
19 | d <- funD (mkName mapperName) clauses
20 | ptraceQ d
21 | return [d]
22 |
23 | mkMapAll :: String -> Info -> Q [ClauseQ]
24 | mkMapAll mappedQualificator i = case i of
25 | TyConI (DataD _ n _ cons _) -> return $ map (mkMapOne mappedQualificator) cons
26 |
27 | mkMapOne :: String -> Con -> ClauseQ
28 | mkMapOne q c | null q = mkMapOne' [] c
29 | | otherwise = mkMapOne' (q ++ ".") c
30 | where
31 | mkMapOne' qualificator (NormalC n fs) = do
32 | let (n1:ns) = nameBase n
33 | let mappedFuncName = mkName $ qualificator ++ (toLower n1 : ns) :: Name
34 | args <- sequence $ replicate (length fs) $ newName "x" :: Q [Name]
35 | let qargs = map varP args
36 | let eargs = map varE args
37 | let apExpr = appsE (varE mappedFuncName : eargs)
38 | clause [conP n qargs] (normalB apExpr) []
39 |
40 |
41 |
42 |
--------------------------------------------------------------------------------
/Tests/TestDataGeneration.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import qualified System.Random as R
4 |
5 | rndG1 = R.mkStdGen 10101010
6 | rndG2 = R.mkStdGen 2424
7 | rndG3 = R.mkStdGen 663536
8 | rndG4 = R.mkStdGen 223636
9 | rndG5 = R.mkStdGen 484884
10 |
11 | ints from to = [from..to]
12 |
13 | negativeInts from to = map negate (ints from to)
14 |
15 | uppers = ['A'..'Z']
16 | lowers = ['a'..'z']
17 | letters = lowers ++ uppers
18 |
19 | rndIndex :: RandomGen g => g -> Int -> (Int, g)
20 | rndIndex rndGen upperBound = R.randomR (0, upperBound) rndGen
21 |
22 | randomItem rndGen list = let
23 | (idx, _) = rndIndex rndGen (length list - 1)
24 | in list !! idx
25 |
26 | names = (randomItem rndGen1 uppers) :
--------------------------------------------------------------------------------
/Tests/TextRatio.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import qualified Data.List as L
4 |
5 | englishLetters = ['a'..'z'] ++ ['A'..'Z']
6 |
7 |
8 | lettersCount :: String -> (Int, Int)
9 | lettersCount text = let (res, _) = L.mapAccumL f (0,0) text
10 | in res
11 | where
12 | f (a, t) x | x `elem` englishLetters = ((a + 1, t + 1), x)
13 | f (a, t) x | otherwise = ((a , t + 1), x)
14 |
15 |
16 | divide l t = (fromIntegral l) / (fromIntegral t)
17 |
18 | main = do
19 | --let testText = "ABC2@#%#$^#$&f"
20 | fileCont <- readFile "text.txt"
21 | let (letters, total) = lettersCount fileCont
22 | putStrLn $ "Letters count: " ++ show letters
23 | putStrLn $ "Total count: " ++ show total
24 | putStrLn $ "Ratio = " ++ (show $ divide letters total)
25 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Tests/TextRatio2.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import qualified Data.List as L
4 | import qualified Data.ByteString.Char8 as C
5 |
6 | englishLetters = C.pack $ "ABCDEFGHIJKLMNOPQRSTUVWXYZ" ++ "abcdefghijklmnopqrstuvwxyz"
7 | --rusLetters = C.pack $ "АБВГДЕЁЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯ" ++ "абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
8 | space = C.pack " "
9 | letters = C.concat [englishLetters, space]
10 |
11 | lettersCount :: C.ByteString -> (Int, Int)
12 | lettersCount text = let
13 | textLen = C.length text
14 | in (lettersCount' 0 text, textLen)
15 | where
16 | lettersCount' cnt txt | C.null txt = cnt
17 | | otherwise = let
18 | (symb, rest) = C.splitAt 1 txt
19 | in if symb `C.isInfixOf` letters
20 | then lettersCount' (cnt + 1) rest
21 | else lettersCount' cnt rest
22 |
23 | lettersCount1 = fst . lettersCount
24 |
25 | popSymbol = C.take 1
26 | symbolBalance outS inS | isFirst && isSecond = 0
27 | | isFirst && (not isSecond) = (-1)
28 | | (not isFirst) && isSecond = 1
29 | | otherwise = 0
30 | where
31 | isFirst = outS `C.isInfixOf` letters
32 | isSecond = inS `C.isInfixOf` letters
33 |
34 |
35 | slide (pointer1, pointer2) res@(s, lCount) | C.null pointer2 = [res]
36 | | otherwise = let
37 | outSymbol = C.take 1 pointer1
38 | inSymbol = C.take 1 pointer2
39 | newLettersCount = lCount + (symbolBalance outSymbol inSymbol)
40 | in res : slide (C.drop 1 pointer1, C.drop 1 pointer2) (outSymbol, newLettersCount)
41 |
42 | letterMap wnd text = let
43 | t@(starter, pointer2) = C.splitAt wnd text
44 | pointer1 = C.drop 1 text
45 | firstSymbol = C.take 1 text
46 | fitstWindowLettersCount = lettersCount1 starter
47 | in if (C.length starter < wnd)
48 | then []
49 | else slide (pointer1, pointer2) (firstSymbol, fitstWindowLettersCount)
50 |
51 | divide l t = (fromIntegral l) / (fromIntegral t)
52 |
53 | escape symbol | symbol == C.singleton '\n' = C.pack "
"
54 | | otherwise = symbol
55 |
56 | ratioTaggedMap wnd lMap = map f lMap
57 | where
58 | f (symbol, cnt) = let
59 | ratio = (divide cnt wnd) * 100.0
60 | strRatio1 = if ratio > 30.0 then "100"
61 | else take 2 (show ratio)
62 | strRatio2 = take 2 (show ratio)
63 | tagPrefix = C.pack $ ""
64 | tagPostfix = C.pack $ ""
65 | escapedSymbol = escape symbol
66 | in C.concat [tagPrefix, escapedSymbol, tagPostfix]
67 |
68 | htmlize t = C.concat [htmlPrefix, t, htmlPostfix]
69 | where
70 | htmlPrefix = C.pack ""
71 | htmlPostfix = C.pack ""
72 |
73 | main = do
74 | --let testText = "ABC2@#%#$^#$&f"
75 | fileCont <- C.readFile "text.txt"
76 | let (lCount, total) = lettersCount fileCont
77 | putStrLn $ "Letters count: " ++ show lCount
78 | putStrLn $ "Total count: " ++ show total
79 | putStrLn $ "Ratio = " ++ (show $ divide lCount total)
80 |
81 | let wnd = 10
82 | let lMap = letterMap wnd fileCont
83 | let tagged = C.concat $ ratioTaggedMap wnd lMap
84 | let html = htmlize tagged
85 | C.writeFile "taggedSymbols4.html" html
86 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Tests/Tmp.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import System.Random
4 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/.gitignore:
--------------------------------------------------------------------------------
1 | .stack-work/
2 | transition-graph.cabal
3 | *~
4 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/ChangeLog.md:
--------------------------------------------------------------------------------
1 | # Changelog for transition-graph
2 |
3 | ## Unreleased changes
4 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright Author name here (c) 2018
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 Author name here 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 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/README.md:
--------------------------------------------------------------------------------
1 | # transition-graph
2 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/app/AdvGame/AdvGameRuntime.hs:
--------------------------------------------------------------------------------
1 | module AdvGame.AdvGameRuntime where
2 |
3 | import Control.Monad (mapM)
4 | import Control.Monad.Trans.Class (lift)
5 | import qualified Data.Map as Map
6 | import Control.Monad.Free (Free (..), foldFree, liftF)
7 | import Control.Monad.Trans.State (StateT, get, put)
8 |
9 | import AdvGame.Lang
10 |
11 | data AdvGameRuntime = AdvGameRuntime
12 | { _inventory :: Map.Map String Item
13 | }
14 |
15 | type Interpreter a = StateT AdvGameRuntime IO a
16 |
17 | interpret :: AdventureLF s -> Interpreter s
18 | interpret (PrintS s next) = const next <$> (lift $ putStrLn s)
19 | interpret (Put s next) = error "Not implemented."
20 | interpret (Drop s next) = error "Not implemented."
21 | interpret (List next) = do
22 | AdvGameRuntime inv <- get
23 | mapM (lift . putStrLn . snd) $ Map.toList inv
24 | pure next
25 |
26 | run :: AdventureL s -> Interpreter (String, s)
27 | run l = do
28 | result <- foldFree interpret l
29 | input <- lift getLine
30 | pure (input, result)
31 |
32 | initialAdvGameRuntime :: AdvGameRuntime
33 | initialAdvGameRuntime = AdvGameRuntime Map.empty
34 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/app/AdvGame/Lang.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE RankNTypes #-}
4 |
5 | module AdvGame.Lang where
6 |
7 | import Control.Monad (void, when)
8 | import Control.Monad.Free (Free (..), foldFree, liftF)
9 | import Control.Monad.State (State (..), evalState, execState,
10 | get, put, runState)
11 | import qualified Control.Monad.Trans.State as ST
12 |
13 | import Data.Exists
14 |
15 | type Item = String
16 |
17 | data AdventureLF a
18 | = PrintS String a
19 | | Put Item a
20 | | Drop Item a
21 | | List a
22 |
23 | type AdventureL = Free AdventureLF
24 |
25 | instance Functor AdventureLF where
26 | fmap f (PrintS s next) = PrintS s (f next)
27 | fmap f (Put s next) = Put s (f next)
28 | fmap f (Drop s next) = Drop s (f next)
29 | fmap f (List next) = List (f next)
30 |
31 | printS :: String -> AdventureL ()
32 | printS s = liftF $ PrintS s ()
33 |
34 | put :: String -> AdventureL ()
35 | put s = liftF $ Put s ()
36 |
37 | drop :: String -> AdventureL ()
38 | drop s = liftF $ Drop s ()
39 |
40 | list :: AdventureL ()
41 | list = liftF $ List ()
42 |
43 | nop :: AdventureL ()
44 | nop = pure ()
45 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Control.Monad.Free (Free (..), foldFree, liftF)
4 | import qualified Data.ByteString.Char8 as BS
5 | import Control.Monad.Trans.State (runStateT)
6 |
7 | import Lib as Lib
8 | import AdvGame.Lang
9 | import AdvGame.AdvGameRuntime
10 |
11 | type AGGraph a b = Lib.Graph AdventureL a b
12 |
13 | travel3Graph :: AGGraph () ()
14 | travel3Graph = graph $
15 | with location3
16 | <~> on "forward" (leaf nop)
17 | <~> on "list" (leaf list)
18 |
19 | travel2Graph :: AGGraph () ()
20 | travel2Graph = graph $
21 | with location2
22 | <~> on "forward" travel3Graph
23 | <~> on "list" (leaf list)
24 |
25 | travel1Graph :: AGGraph () ()
26 | travel1Graph = graph $
27 | with location1
28 | <~> on "forward" travel2Graph
29 | <~> on "list" (leaf list)
30 |
31 | location1 :: AdventureL ()
32 | location1 = location "West of House\n\
33 | \This is an open field west of a white house, with a boarded front door.\n\
34 | \There is a small mailbox here.\n\
35 | \A rubber mat saying 'Welcome to Zork!' lies by the door."
36 |
37 | location2 :: AdventureL ()
38 | location2 = location "Another location."
39 |
40 | location3 :: AdventureL ()
41 | location3 = location "Location #3."
42 |
43 | location :: String -> AdventureL ()
44 | location = printS
45 |
46 |
47 | main :: IO ()
48 | main = do
49 | let runtime = Runtime run (== "back")
50 | res <- runStateT (runGraph runtime travel1Graph) initialAdvGameRuntime
51 |
52 |
53 | pure ()
54 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/package.yaml:
--------------------------------------------------------------------------------
1 | name: transition-graph
2 | version: 0.1.0.0
3 | github: "githubuser/transition-graph"
4 | license: BSD3
5 | author: "Author name here"
6 | maintainer: "example@example.com"
7 | copyright: "2018 Author name here"
8 |
9 | extra-source-files:
10 | - README.md
11 | - ChangeLog.md
12 |
13 | # Metadata used when publishing your package
14 | # synopsis: Short description of your package
15 | # category: Web
16 |
17 | # To avoid duplicated efforts in documentation and dealing with the
18 | # complications of embedding Haddock markup inside cabal files, it is
19 | # common to point users to the README.md file.
20 | description: Please see the README on Github at
21 |
22 | dependencies:
23 | - base >= 4.7 && < 5
24 | - free
25 | - bytestring
26 | - mtl
27 | - transformers
28 | - hspec
29 | - containers
30 |
31 | library:
32 | source-dirs: src
33 |
34 | executables:
35 | transition-graph-exe:
36 | main: Main.hs
37 | source-dirs: app
38 | ghc-options:
39 | - -threaded
40 | - -rtsopts
41 | - -with-rtsopts=-N
42 | dependencies:
43 | - transition-graph
44 |
45 | tests:
46 | transition-graph-test:
47 | main: Spec.hs
48 | source-dirs: test
49 | ghc-options:
50 | - -threaded
51 | - -rtsopts
52 | - -with-rtsopts=-N
53 | dependencies:
54 | - transition-graph
55 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/src/Data/Exists.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE RankNTypes, GADTs #-}
2 | module Data.Exists where
3 |
4 | import Unsafe.Coerce (unsafeCoerce)
5 |
6 | data Exists f where
7 | Exists :: f a -> Exists f
8 |
9 | mkExists :: forall f a. f a -> Exists f
10 | mkExists = unsafeCoerce
11 |
12 | runExists :: forall f r. (forall a. f a -> r) -> (Exists f -> r)
13 | runExists = unsafeCoerce
14 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/src/Lib.hs:
--------------------------------------------------------------------------------
1 | module Lib ( module X ) where
2 |
3 | import Data.Exists as X
4 |
5 | import TransitionGraph.Runtime as X
6 | import TransitionGraph.Graph as X
7 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/src/TransitionGraph/Graph.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE RankNTypes #-}
4 |
5 | {-# LANGUAGE PartialTypeSignatures #-}
6 |
7 | module TransitionGraph.Graph where
8 |
9 | import Control.Monad (void, when)
10 | import Control.Monad.Free (Free (..), foldFree, liftF)
11 | import Control.Monad.State (State (..), evalState, execState,
12 | get, put, runState)
13 | import qualified Control.Monad.Trans.State as ST
14 |
15 | import Data.Exists
16 |
17 | type Event = String
18 |
19 | data TransitionF lang b o u
20 | = Backable Event (Graph lang b o) u
21 | | ForwardOnly Event (Graph lang b o) u
22 |
23 | type Transition lang b o u = Free (TransitionF lang b o) u
24 |
25 | data GraphF lang i o b
26 | = GraphF ( lang b) (Transition lang b o ())
27 | | GraphF1 (i -> lang b) (Transition lang b o ())
28 |
29 | newtype Graph lang i o
30 | = Graph (Exists (GraphF lang i o))
31 |
32 | type PartialTrans lang i o b = Transition lang b o () -> Graph lang i o
33 | data Event' lang i o = Event' Event (Graph lang i o)
34 |
35 | instance Functor (TransitionF lang b o) where
36 | fmap f (Backable e g next) = Backable e g (f next)
37 | fmap f (ForwardOnly e g next) = ForwardOnly e g (f next)
38 |
39 | (<~>) = transable backable
40 | (~>) = transable forwardOnly
41 |
42 | infixl 3 <~>
43 | infixl 3 ~>
44 |
45 | with
46 | :: (Monad lang)
47 | => lang b
48 | -> Transition lang b o ()
49 | -> Graph lang () o
50 | with flow table = Graph $ mkExists $ GraphF flow table
51 |
52 | with1
53 | :: (Monad lang)
54 | => (i -> lang b)
55 | -> Transition lang b o ()
56 | -> Graph lang i o
57 | with1 flowF1 table = Graph $ mkExists $ GraphF1 flowF1 table
58 |
59 | leaf
60 | :: (Monad lang)
61 | => lang ()
62 | -> Graph lang () ()
63 | leaf flow = with flow (pure ())
64 |
65 | leaf1
66 | :: (Monad lang)
67 | => (i -> lang ())
68 | -> Graph lang i ()
69 | leaf1 flowF1 = with1 flowF1 (pure ())
70 |
71 | graph part = part $ pure ()
72 |
73 | on
74 | :: Event
75 | -> Graph lang i o
76 | -- -> (forall (lang :: * -> *). Graph lang i o)
77 | -> Event' lang i o
78 | on = Event'
79 |
80 | transable
81 | :: (Event
82 | -> Graph lang i o
83 | -> Free (TransitionF lang i o) b
84 | )
85 | -> (Free (TransitionF lang i o) b -> c)
86 | -> Event' lang i o
87 | -> Free (TransitionF lang i o) a
88 | -> c
89 |
90 | transable transType part (Event' e g) = part . transed
91 | where
92 | transed prevTrans = do
93 | prevTrans
94 | transType e g
95 |
96 | backable
97 | :: Event
98 | -> Graph lang i o
99 | -> Transition lang i o ()
100 | backable e g = liftF $ Backable e g ()
101 |
102 | forwardOnly
103 | :: Event
104 | -> Graph lang i o
105 | -> Transition lang i o ()
106 | forwardOnly e g = liftF $ ForwardOnly e g ()
107 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/src/TransitionGraph/Interpreter.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE RankNTypes #-}
4 |
5 | module TransitionGraph.Interpreter where
6 |
7 | import Control.Monad (void, when)
8 | import Control.Monad.Free (Free (..), foldFree, liftF)
9 | import Control.Monad.State (State (..), evalState, execState,
10 | get, put, runState)
11 | import qualified Control.Monad.Trans.State as ST
12 |
13 | import Data.Exists
14 |
15 | import TransitionGraph.Graph
16 |
17 | data TrackResult a = BackTrack a | ForwardTrack a | Nop
18 | data LangResult a b = Forward a b | Backward
19 | data TransitionResult = Fallback | FallbackRerun | Done
20 |
21 | interpretTransition
22 | :: Event
23 | -> TransitionF lang b o u
24 | -> State (TrackResult (Graph lang b o)) u
25 | interpretTransition e (Backable expectedE g next) = do
26 | when (e == expectedE) (put $ BackTrack g)
27 | pure next
28 | interpretTransition e (ForwardOnly expectedE g next) = do
29 | when (e == expectedE) (put $ ForwardTrack g)
30 | pure next
31 |
32 | runTransition'
33 | :: Event
34 | -> Transition lang b o s
35 | -> State (TrackResult (Graph lang b o)) s
36 | runTransition' e = foldFree (interpretTransition e)
37 |
38 | runTransition
39 | :: Event
40 | -> GraphF lang i o b
41 | -> TrackResult (Graph lang b o)
42 | runTransition e (GraphF _ t) = execState (runTransition' e t) Nop
43 | runTransition e (GraphF1 _ t) = execState (runTransition' e t) Nop
44 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/src/TransitionGraph/Runtime.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification #-}
2 | {-# LANGUAGE FlexibleContexts #-}
3 | {-# LANGUAGE RankNTypes #-}
4 |
5 | module TransitionGraph.Runtime where
6 |
7 | import Control.Monad (void, when)
8 | import Control.Monad.Free (Free (..), foldFree, liftF)
9 | import Control.Monad.State (State (..), evalState, execState,
10 | get, put, runState)
11 | import qualified Control.Monad.Trans.State as ST
12 |
13 | import Data.Exists
14 |
15 | import TransitionGraph.Graph
16 | import TransitionGraph.Interpreter
17 |
18 | data Runtime lang m = Runtime
19 | { runLang_ :: forall output. lang output -> m (Event, output)
20 | , isBackEvent_ :: Event -> Bool
21 | }
22 |
23 | runLang'
24 | :: (Monad m, Monad lang)
25 | => Runtime lang m
26 | -> lang a
27 | -> m (LangResult Event a)
28 | runLang' (Runtime runLang isBackEvent) flow = do
29 | (e, i) <- runLang flow
30 | if isBackEvent e
31 | then pure Backward
32 | else pure $ Forward e i
33 |
34 | getLang
35 | :: i
36 | -> GraphF lang i o b
37 | -> lang b
38 | getLang _ (GraphF flow _) = flow
39 | getLang input (GraphF1 flowF _) = flowF input
40 |
41 | makeTransition'
42 | :: (Monad m, Monad lang)
43 | => Runtime lang m
44 | -> Bool
45 | -> i
46 | -> GraphF lang i o b
47 | -> m TransitionResult
48 | makeTransition' runtime backable i3 g3 = do
49 | let f3 = getLang i3 g3
50 | transitionResult <- makeTransition runtime f3 g3
51 | case transitionResult of
52 | Done -> pure Done
53 | FallbackRerun -> makeTransition' runtime backable i3 g3
54 | Fallback ->
55 | if backable
56 | then pure FallbackRerun
57 | else pure Done -- throw "No fallback"
58 |
59 | makeTransition
60 | :: (Monad m, Monad lang)
61 | => Runtime lang m
62 | -> lang b
63 | -> GraphF lang i o b
64 | -> m TransitionResult
65 | makeTransition runtime f2 g2 = do
66 | flowResult <- runLang' runtime f2
67 | case flowResult of
68 | Backward -> pure Fallback
69 | Forward e2 i3 -> do
70 | let trackResult = runTransition e2 g2
71 | case trackResult of
72 | Nop -> pure Done
73 | BackTrack g3@(Graph g3Ex) -> runExists (makeTransition' runtime True i3) g3Ex
74 | ForwardTrack g3@(Graph g3Ex) -> runExists (makeTransition' runtime False i3) g3Ex
75 |
76 | runGraph
77 | :: (Monad m, Monad lang)
78 | => Runtime lang m
79 | -> Graph lang () ()
80 | -> m ()
81 | runGraph runtime (Graph ex) = do
82 | _ <- runExists (makeTransition' runtime False ()) ex
83 | pure ()
84 |
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/stack.yaml:
--------------------------------------------------------------------------------
1 | # This file was automatically generated by 'stack init'
2 | #
3 | # Some commonly used options have been documented as comments in this file.
4 | # For advanced use and comprehensive documentation of the format, please see:
5 | # https://docs.haskellstack.org/en/stable/yaml_configuration/
6 |
7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version.
8 | # A snapshot resolver dictates the compiler version and the set of packages
9 | # to be used for project dependencies. For example:
10 | #
11 | # resolver: lts-3.5
12 | # resolver: nightly-2015-09-21
13 | # resolver: ghc-7.10.2
14 | # resolver: ghcjs-0.1.0_ghc-7.10.2
15 | # resolver:
16 | # name: custom-snapshot
17 | # location: "./custom-snapshot.yaml"
18 | resolver: lts-11.4
19 |
20 | # User packages to be built.
21 | # Various formats can be used as shown in the example below.
22 | #
23 | # packages:
24 | # - some-directory
25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz
26 | # - location:
27 | # git: https://github.com/commercialhaskell/stack.git
28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30 | # extra-dep: true
31 | # subdirs:
32 | # - auto-update
33 | # - wai
34 | #
35 | # A package marked 'extra-dep: true' will only be built if demanded by a
36 | # non-dependency (i.e. a user package), and its test suites and benchmarks
37 | # will not be run. This is useful for tweaking upstream packages.
38 | packages:
39 | - .
40 | # Dependency packages to be pulled from upstream that are not in the resolver
41 | # (e.g., acme-missiles-0.3)
42 | # extra-deps: []
43 |
44 | # Override default flag values for local packages and extra-deps
45 | # flags: {}
46 |
47 | # Extra package databases containing global packages
48 | # extra-package-dbs: []
49 |
50 | # Control whether we use the GHC we find on the path
51 | # system-ghc: true
52 | #
53 | # Require a specific version of stack, using version ranges
54 | # require-stack-version: -any # Default
55 | # require-stack-version: ">=1.6"
56 | #
57 | # Override the architecture used by stack, especially useful on Windows
58 | # arch: i386
59 | # arch: x86_64
60 | #
61 | # Extra directories used by stack for building
62 | # extra-include-dirs: [/path/to/dir]
63 | # extra-lib-dirs: [/path/to/dir]
64 | #
65 | # Allow a newer minor version of GHC than the snapshot specifies
66 | # compiler-check: newer-minor
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/test/Spec.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
--------------------------------------------------------------------------------
/Tests/TransitionGraph/transition-graph/test/TransitionGraphSpec.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | {-# LANGUAGE RankNTypes #-}
3 |
4 | module TransitionGraphSpec where
5 |
6 | import Control.Monad.Free (Free (..), foldFree, liftF)
7 | import qualified Data.ByteString.Char8 as BS
8 | import Test.Hspec
9 |
10 | import Lib
11 |
12 | travel3Graph :: Graph IO () ()
13 | travel3Graph = graph $
14 | with (print "3")
15 | <~> on "forward" (leaf (return ()))
16 |
17 | travel2Graph :: Graph IO () ()
18 | travel2Graph = graph $
19 | with (print "2")
20 | <~> on "forward" travel3Graph
21 |
22 | travel1Graph :: Graph IO () ()
23 | travel1Graph = graph $
24 | with (print "1")
25 | <~> on "forward" travel2Graph
26 |
27 | ioRunner :: IO output -> IO (Event, output)
28 | ioRunner act = act >>= \o -> pure ("forward", o)
29 |
30 | spec = describe "Graph transitions test." $
31 | it "Test Graph transitions." $
32 | runGraph (GraphRuntime ioRunner (== "back")) travel1Graph
33 |
--------------------------------------------------------------------------------
/Tests/TypeClasses/TypeClasses.hs:
--------------------------------------------------------------------------------
1 | module TypeClasses where
2 |
3 | import Prelude hiding (sum)
4 |
5 | data Point = Point Int Int
6 |
7 | class SumProvider t where
8 | sum :: t -> Int -> Int -> Int
9 |
10 | class MulProvider t where
11 | mul :: t -> Int -> Int -> Int
12 |
13 | data Summator1 = S1
14 | data Summator2 = S2
15 |
16 | data Multiplier1 = M1 Int
17 |
18 | instance SumProvider Summator1 where
19 | sum S1 x y = x + y
20 |
21 | instance SumProvider Summator2 where
22 | sum S2 x y = x + y + 100
23 |
24 | instance MulProvider Multiplier1 where
25 | mul (M1 coeff) x y = x * y * coeff
26 |
27 | dotProduct :: (SumProvider s, MulProvider m) => s -> m -> Point -> Point -> Int
28 | dotProduct s m x y = mul m (sum s 3 5) 10
29 |
30 | main = do
31 | let result1 = dotProduct S1 (M1 1) (Point 0 0) (Point 0 0)
32 | let result2 = dotProduct S2 (M1 2) (Point 0 0) (Point 0 0)
33 |
34 | print result1 -- 80
35 | print result2 -- 2060
36 |
37 |
38 |
--------------------------------------------------------------------------------
/Tests/Types/Command.hs:
--------------------------------------------------------------------------------
1 | module Command (run, getInfo, Command(..), CommandHolder(..)) where
2 |
3 | class Command a where
4 | run :: a -> IO ()
5 | getInfo :: a -> String
6 |
7 | data CommandHolder a = CommandHolder (IO ())
8 |
--------------------------------------------------------------------------------
/Tests/Types/Hardware1.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 |
3 | module Hardware1 (start, stop) where
4 |
5 | import Command
6 |
7 | data Start
8 | data Stop
9 |
10 |
11 | instance Command (CommandHolder Start) where
12 | run (CommandHolder io) = io -- TODO: how to get rid of boilerplate?
13 | getInfo (CommandHolder c) = show $ "Start"
14 |
15 |
16 | instance Command (CommandHolder Stop) where
17 | run (CommandHolder io) = io -- TODO: how to get rid of boilerplate?
18 | getInfo (CommandHolder c) = show $ "Stop"
19 |
20 | start :: CommandHolder Start
21 | start = CommandHolder $ putStrLn "command start"
22 |
23 | stop :: CommandHolder Stop
24 | stop = CommandHolder $ putStrLn "command stop"
25 |
26 |
27 |
--------------------------------------------------------------------------------
/Tests/Types/Hardware2.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 |
3 | module Hardware2 (rotate) where
4 |
5 | import Command
6 |
7 | data Rotate
8 |
9 | instance Command (CommandHolder Rotate) where
10 | run (CommandHolder c) = c
11 | getInfo (CommandHolder c) = show $ "Rotate"
12 |
13 |
14 | rotate :: CommandHolder Rotate
15 | rotate = CommandHolder $ putStrLn "command Rotate"
16 |
17 |
18 |
19 |
20 |
21 |
--------------------------------------------------------------------------------
/Tests/Types/PhantomTypeCoerce.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE DeriveFunctor #-}
2 | {-# LANGUAGE Rank2Types #-}
3 | {-# LANGUAGE GADTs #-}
4 | {-# LANGUAGE ScopedTypeVariables #-}
5 |
6 | module PhantomTypeCoerce where
7 |
8 | import Control.Monad.Free
9 | import Prelude hiding (read)
10 | import Unsafe.Coerce
11 | import Data.Typeable
12 |
13 | newtype Measurement tag = Measurement Float
14 | deriving (Show, Read, Eq)
15 |
16 | data Kelvin
17 | data Pascal
18 | type Temperature = Measurement Kelvin
19 | type Pressure = Measurement Pascal
20 |
21 | data Procedure tag a where
22 | Read :: tag -> (Measurement tag -> a) -> Procedure tag a
23 | RunCommand :: String -> a -> Procedure tag a
24 | deriving (Functor)
25 |
26 | type Script tag a = Free (Procedure tag) a
27 |
28 | -- private function:
29 | read :: tag -> Script () (Measurement tag)
30 | read p = liftF (Read p id)
31 |
32 | -- Free DSL:
33 | readTemperature :: Script () Temperature
34 | readTemperature = read (undefined :: Kelvin)
35 |
36 | readPressure :: Script () Pressure
37 | readPressure = read (undefined :: Pascal)
38 |
39 | runCommand :: String -> Script () ()
40 | runCommand cmd = liftF (RunCommand cmd ())
41 |
42 | -- Unsafe, want to get rid of.
43 | untag = unsafeCoerce
44 |
45 | toKelvin :: Float -> Temperature
46 | toKelvin = Measurement
47 | fromKelvin :: Measurement Kelvin -> Float
48 | fromKelvin (Measurement v) = v
49 | toPascal :: Float -> Pressure
50 | toPascal = Measurement
51 | fromPascal :: Measurement Pascal -> Float
52 | fromPascal (Measurement v) = v
53 |
54 | --readT :: Script () Float
55 | readT = do
56 | t <- readTemperature
57 | return $ fromKelvin t
58 |
59 | --readP :: Script () Float
60 | readP = do
61 | t <- readPressure
62 | return $ fromPascal t
63 |
64 | -- Script to be interpreted
65 | --script :: Script () (Float, Float, Float)
66 | script = do
67 | temp1 <- readT
68 | press1 <- readP
69 | temp2 <- readT
70 | return (temp1, press1, temp2)
71 |
72 | -- Interpreter
73 | scriptInterpreter (Pure a) = return a
74 | scriptInterpreter (Free proc) = case proc of
75 | Read p next -> case cast p of
76 | Just (_ :: Kelvin) -> do
77 | print "Read temperature."
78 | scriptInterpreter (next $ toKelvin 100.0)
79 | Nothing -> error $ "Bad cast: " ++ show (typeOf p)
80 | RunCommand cmd next -> do
81 | print $ "Some command to be run: " ++ cmd
82 | scriptInterpreter next
83 |
84 |
--------------------------------------------------------------------------------
/Tests/Types/PhantomTypeHints.hs:
--------------------------------------------------------------------------------
1 | module TypeHint where
2 |
3 |
4 | data Val a b = Val b
5 |
6 |
7 |
8 | data CelsiusHint
9 | data KelvinHint
10 |
11 |
12 | getTemperature :: Val KelvinHint Float
13 | getTemperature = Val 44.6
14 |
15 | toCelsius :: Val KelvinHint Float -> Val CelsiusHint Float
16 | toCelsius (Val k) = Val $ k - 273.15
17 |
18 | calculateSmth :: Val CelsiusHint Float -> Float
19 | calculateSmth (Val c) = c * 100.0
20 |
21 |
22 |
23 | calculateSmthElse :: Val KelvinHint Float -> Float
24 | calculateSmthElse (Val c) = c + 100.0
25 |
26 |
--------------------------------------------------------------------------------
/Tests/Types/Test.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Command
4 | import Hardware1
5 | import Hardware2
6 |
7 |
8 |
9 | main = do
10 | run start
11 | run stop
12 | print $ getInfo start
13 | print $ getInfo stop
14 | run rotate
15 |
16 |
17 | print ""
18 |
--------------------------------------------------------------------------------
/Tests/Types/TypeCalculation.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE TypeFamilies #-}
2 |
3 | data Z
4 | data S n = S {sArgument :: n}
5 | type family Plus a b
6 | type instance Plus Z a = a
7 | type instance Plus (S a) b = S (Plus a b)
8 |
9 | type ONE = S Z
10 | type TWO = Plus (S Z) (S Z)
11 |
12 |
13 | class NatInt a
14 | where natInt :: a -> Int
15 |
16 | instance NatInt Z where
17 | natInt = const 0
18 | instance NatInt n => NatInt (S n) where
19 | natInt (S n) = 1 + natInt n
--------------------------------------------------------------------------------
/Tests/Types/TypeFamilies/TypeFamilyTest1.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 | {-# LANGUAGE TypeSynonymInstances #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE ExistentialQuantification #-}
5 | {-# LANGUAGE GADTs #-}
6 | {-# LANGUAGE RankNTypes #-}
7 |
8 | module Main where
9 |
10 | type Caption = String
11 | type Name = String
12 | type PlayerName = String
13 |
14 | data IntProperty = IntProperty Name Int
15 | deriving (Show, Read, Eq)
16 | data IntResource = IntResource Name (Int, Int)
17 | deriving (Show, Read, Eq)
18 |
19 | class Show a => Prop a where
20 | type Out a :: *
21 | getProperty :: a -> Out a
22 |
23 | instance Prop IntProperty where
24 | type Out IntProperty = Int
25 | getProperty (IntProperty _ k) = k
26 |
27 | instance Prop IntResource where
28 | type Out IntResource = (Int, Int)
29 | getProperty (IntResource _ k) = k
30 |
31 |
32 | data PropertyToken = forall p. Prop p => MkPropertyToken p
33 | type PropertyTokens = [PropertyToken]
34 |
35 | data RawToken = Item Name PropertyTokens
36 |
37 | instance Show PropertyToken where
38 | show (MkPropertyToken p) = show p
39 |
40 |
41 |
42 | token1 = MkPropertyToken (IntProperty "int" 10)
43 | token2 = MkPropertyToken (IntResource "intResource" (10, 1000))
44 | tokens = [token1, token2]
45 |
46 | rawToken = Item "RawToken" tokens
47 |
48 | main = do
49 | print $ getProperty (IntProperty "a" 10)
50 | print $ getProperty (IntResource "b" (20, 20))
51 |
52 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Tests/Types/TypeFamilies/TypeFamilyTest2.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 | {-# LANGUAGE TypeSynonymInstances #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE ExistentialQuantification #-}
5 | {-# LANGUAGE GADTs #-}
6 | {-# LANGUAGE RankNTypes #-}
7 |
8 | module Main where
9 |
10 | type Caption = String
11 | type Name = String
12 | type PlayerName = String
13 |
14 | data IntProperty = IntProperty Name Int
15 | deriving (Show, Read, Eq)
16 | data IntResource = IntResource Name (Int, Int)
17 | deriving (Show, Read, Eq)
18 |
19 | class Prop a where
20 | type Out a :: *
21 | getProperty :: a -> Out a
22 |
23 | class PropertyBag a where
24 | type Elem a :: *
25 | empty :: a
26 | insert :: Elem a -> a -> a
27 | toList :: a -> [Elem a]
28 |
29 | instance Prop a => PropertyBag [a] where
30 | type Elem [a] = a
31 | empty = []
32 | toList l = l
33 | insert a l = a : l
34 |
35 |
36 | instance Prop IntProperty where
37 | type Out IntProperty = Int
38 | getProperty (IntProperty _ k) = k
39 |
40 | instance Prop IntResource where
41 | type Out IntResource = (Int, Int)
42 | getProperty (IntResource _ k) = k
43 |
44 | {-
45 | So, what?
46 | f :: (PropertyBag a, Prop b, b ~ Elem a) => a -> [b]
47 | f bag = toList bag
48 |
49 | prop1 = IntProperty "aa" 10
50 | b :: (PropertyBag a, Prop p, p ~ Elem a) => p -> a
51 | b p = insert (getProperty p) empty
52 | -}
53 |
54 | main = putStrLn "Ok."
55 |
56 |
--------------------------------------------------------------------------------
/Tests/Types/TypeFamilies/TypeFamilyTest3.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances #-}
2 | {-# LANGUAGE TypeSynonymInstances #-}
3 | {-# LANGUAGE TypeFamilies #-}
4 | {-# LANGUAGE ExistentialQuantification #-}
5 | {-# LANGUAGE GADTs #-}
6 | {-# LANGUAGE RankNTypes #-}
7 |
8 | module Main where
9 |
10 | type Caption = String
11 | type Name = String
12 | type PlayerName = String
13 |
14 |
15 | data PropertyToken a where
16 | IntProperty :: Name -> Int -> PropertyToken Int
17 | IntResource :: Name -> (Int, Int) -> PropertyToken (Int, Int)
18 |
19 | instance Show (PropertyToken Int) where
20 | show (IntProperty _ i) = show i
21 |
22 | instance Show (PropertyToken (Int, Int)) where
23 | show (IntResource _ i) = show i
24 |
25 | class (Show a) => Prop a where
26 | type Out a b :: *
27 | getProperty :: (a ~ Out b ()) => a -> Out a ()
28 | printProperty :: a -> String
29 |
30 | instance Prop (PropertyToken a) where
31 | type Out (PropertyToken a) a = a
32 | getProperty (IntProperty _ k) = k
33 | getProperty (IntResource _ k) = k
34 | printProperty (IntProperty _ k) = show k
35 | printProperty (IntResource _ k) = show k
36 |
37 | instance Show (PropertyToken a) where
38 | show (IntProperty _ k) = show k
39 | show (IntResource _ k) = show k
40 |
41 |
42 | data Wrap = forall p. Prop p => MkWrap p
43 |
44 | instance Show Wrap where
45 | show (MkWrap p) = show p
46 |
47 | instance Prop Wrap where
48 | --type Out Wrap a = PropertyToken a
49 | getProperty (MkWrap p) = undefined
50 | printProperty = undefined
51 |
52 | type PropList = [Wrap]
53 |
54 | token1 = MkWrap $ IntProperty "int" 10
55 | token2 = MkWrap $ IntResource "intResource" (10, 1000)
56 | tokens = [token1, token2] :: PropList
57 |
58 | main = do
59 | print $ getProperty (IntProperty "a" 10)
60 | print $ getProperty (IntResource "b" (20, 20))
61 | print $ map show tokens
62 | print tokens
63 |
64 |
65 | let res1 = getProperty $ head tokens
66 | -- putStrLn $ printProperty res1
67 |
68 | putStrLn "Ok."
--------------------------------------------------------------------------------
/Tests/Types/YonedaLemma.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Arrows #-}
2 | {-# LANGUAGE GADTs #-}
3 | {-# LANGUAGE DeriveFunctor #-}
4 | {-# LANGUAGE Rank2Types #-}
5 | module YonedaLemma where
6 |
7 | data Value = BoolValue Bool
8 | | IntValue Int
9 | | FloatValue Float
10 | | StringValue String
11 | deriving (Show, Read, Eq)
12 |
13 | data Pascal
14 | data Kelvin
15 |
16 |
17 | newtype Measurment a = Measurment Value
18 | deriving (Show, Read, Eq)
19 |
20 | data Parameter tag = Parameter String (Measurment tag)
21 | deriving (Show, Read, Eq)
22 |
23 | -- Yoneda Lemma:
24 | -- if 'f' is a functor, then there is isomorphism:
25 | -- (forall b. (a -> b) -> f b) ~ f a
26 |
27 | -- f b = ModelDef (Parameter Kelvin -> a)
28 | --
29 |
30 | data ModelDefGadt a tag where
31 | TemperatureParameter :: String -> (Parameter Kelvin -> a) -> ModelDefGadt a Kelvin
32 | PressureParameter :: String -> (Parameter Pascal -> a) -> ModelDefGadt a Pascal
33 |
34 | data ModelDefGadt2 a tag where
35 | TemperatureParameter1 :: String -> (Kelvin -> tag) -> (Parameter Kelvin -> a) -> ModelDefGadt2 a tag
36 | PressureParameter1 :: String -> (Pascal -> tag) -> (Parameter Pascal -> a) -> ModelDefGadt2 a tag
37 |
38 | data ModelDef a tag =
39 | forall t. Param String (t -> tag) (Parameter tag -> a)
40 |
41 |
42 |
43 |
44 | boolValue :: Bool -> Value
45 | boolValue = BoolValue
46 | stringValue :: String -> Value
47 | stringValue = StringValue
48 | intValue :: Int -> Value
49 | intValue = IntValue
50 | floatValue :: Float -> Value
51 | floatValue = FloatValue
52 |
53 |
54 |
55 | toKelvin :: Float -> Measurment Kelvin
56 | toKelvin v = Measurment (floatValue v)
57 | fromKelvin :: Measurment Kelvin -> Float
58 | fromKelvin (Measurment (FloatValue v)) = v
59 | fromPascal :: Measurment Pascal -> Float
60 | fromPascal (Measurment (FloatValue v)) = v
61 |
62 | temperature :: Measurment Kelvin
63 | temperature = toKelvin 0.0
--------------------------------------------------------------------------------
/Tests/Types/dimensions/LICENSE:
--------------------------------------------------------------------------------
1 | Copyright Author name here (c) 2017
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 Author name here 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.
--------------------------------------------------------------------------------
/Tests/Types/dimensions/README.md:
--------------------------------------------------------------------------------
1 | # dimensions
2 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/app/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Lib
4 |
5 | main :: IO ()
6 | main = someFunc
7 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/dimensions.cabal:
--------------------------------------------------------------------------------
1 | name: dimensions
2 | version: 0.1.0.0
3 | -- synopsis:
4 | -- description:
5 | homepage: https://github.com/githubuser/dimensions#readme
6 | license: BSD3
7 | license-file: LICENSE
8 | author: Author name here
9 | maintainer: example@example.com
10 | copyright: 2017 Author name here
11 | category: Web
12 | build-type: Simple
13 | extra-source-files: README.md
14 | cabal-version: >=1.10
15 |
16 | library
17 | hs-source-dirs: src
18 | exposed-modules: Lib
19 | , Dimensions
20 | build-depends: base >= 4.7 && < 5
21 | default-language: Haskell2010
22 |
23 | executable dimensions-exe
24 | hs-source-dirs: app
25 | main-is: Main.hs
26 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
27 | build-depends: base
28 | , dimensions
29 | default-language: Haskell2010
30 |
31 | test-suite dimensions-test
32 | type: exitcode-stdio-1.0
33 | hs-source-dirs: test
34 | main-is: Spec.hs
35 | build-depends: base
36 | , dimensions
37 | , hspec
38 | ghc-options: -threaded -rtsopts -with-rtsopts=-N
39 | default-language: Haskell2010
40 |
41 | source-repository head
42 | type: git
43 | location: https://github.com/githubuser/dimensions
44 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/src/Dimensions.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE Arrows #-}
2 | {-# LANGUAGE GADTs #-}
3 | {-# LANGUAGE DeriveFunctor #-}
4 | {-# LANGUAGE Rank2Types #-}
5 | {-# LANGUAGE MultiParamTypeClasses #-}
6 | {-# LANGUAGE FlexibleInstances #-}
7 | module Dimensions where
8 |
9 | -- https://www.stephanboyer.com/post/131/type-safe-dimensional-analysis-in-haskell
10 |
11 | newtype BaseQuantity a = BaseQuantity Double
12 |
13 | -- a / b
14 | type Quotient a b = b -> a
15 | type Dimensionless = BaseQuantity ()
16 | -- 1 / a
17 | type Inverse a = Quotient Dimensionless a
18 | -- a * b == a / b^-1
19 | type Product a b = Quotient a (Inverse b)
20 |
21 | type Square a = Product a a
22 |
23 | --
24 | class Quantity a where
25 | construct :: Double -> a
26 | destruct :: a -> Double
27 |
28 | --
29 | instance Quantity (BaseQuantity a) where
30 | construct = BaseQuantity
31 | destruct (BaseQuantity x) = x
32 |
33 | --
34 | instance (Quantity q, Quantity r) => Quantity (Quotient r q) where
35 | construct x = \y -> construct (x * (destruct y))
36 | destruct x = destruct (x (construct 1))
37 |
38 | -- a / (b / c) = c / (b / a)
39 | quotientAxiom :: (Quantity a, Quantity b, Quantity c) =>
40 | Quotient a (Quotient b c) -> Quotient c (Quotient b a)
41 | quotientAxiom = construct . destruct
42 |
43 |
44 | ---- Inverse b -> a == a / b^-1 == a * b
45 |
46 | class Productable a b where
47 | (.*.) :: a -> b -> Product a b
48 |
49 | instance (Quantity a, Quantity b) => Productable a b where
50 | (.*.) = mulQ
51 |
52 | instance (Quantity a, Quantity b, Quantity c) => Productable (Quotient a b) c where
53 | (.*.) a b = quotientAxiom (b ./. a) id
54 |
55 | -- We can add two quantities of the same unit.
56 | infixl 6 .+.
57 | (.+.) :: Quantity a => a -> a -> a
58 | (.+.) x y = construct $ (destruct x) + (destruct y)
59 |
60 | -- We can subtract two quantities of the same unit.
61 | infixl 6 .-.
62 | (.-.) :: Quantity a => a -> a -> a
63 | (.-.) x y = construct $ (destruct x) - (destruct y)
64 |
65 | -- We can multiply any two quantities.
66 | infixl 7 .*.
67 | mulQ :: (Quantity a, Quantity b) => a -> b -> Product a b
68 | mulQ x y = \z -> construct $ destruct (z y) * destruct x
69 |
70 | -- We can divide any two quantities.
71 | infixl 7 ./.
72 | (./.) :: (Quantity a, Quantity b) => a -> b -> Quotient a b
73 | (./.) x y = \z -> construct $ (destruct z) * (destruct x) / (destruct y)
74 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/src/Lib.hs:
--------------------------------------------------------------------------------
1 | module Lib
2 | ( someFunc
3 | ) where
4 |
5 | someFunc :: IO ()
6 | someFunc = putStrLn "someFunc"
7 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/stack.yaml:
--------------------------------------------------------------------------------
1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
2 |
3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
4 | resolver: lts-5.5
5 |
6 | # Local packages, usually specified by relative directory name
7 | packages:
8 | - '.'
9 |
10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
11 | extra-deps: []
12 |
13 | # Override default flag values for local packages and extra-deps
14 | flags: {}
15 |
16 | # Extra package databases containing global packages
17 | extra-package-dbs: []
18 |
19 | # Control whether we use the GHC we find on the path
20 | # system-ghc: true
21 |
22 | # Require a specific version of stack, using version ranges
23 | # require-stack-version: -any # Default
24 | # require-stack-version: >= 0.1.10.0
25 |
26 | # Override the architecture used by stack, especially useful on Windows
27 | # arch: i386
28 | # arch: x86_64
29 |
30 | # Extra directories used by stack for building
31 | # extra-include-dirs: [/path/to/dir]
32 | # extra-lib-dirs: [/path/to/dir]
33 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/test/DimensionsSpec.hs:
--------------------------------------------------------------------------------
1 | module DimensionsSpec where
2 |
3 | import Test.Hspec
4 |
5 | import Dimensions
6 |
7 | data Meter
8 | data Kilogram
9 | data Second
10 |
11 | type Length = BaseQuantity Meter
12 | type Mass = BaseQuantity Kilogram
13 | type Time = BaseQuantity Second
14 | type Area = Square Length
15 | type Velocity = Quotient Length Time
16 |
17 | tableWidth :: Length
18 | tableWidth = construct 1.5
19 |
20 | tableHeight :: Length
21 | tableHeight = construct 2.5
22 |
23 | tableArea :: Area
24 | tableArea = tableWidth .*. tableHeight
25 |
26 | velocity :: Velocity
27 | velocity = construct 5.0
28 |
29 | travelTime :: Time
30 | travelTime = construct 60.0
31 |
32 | distance :: Length
33 | distance = velocity .*. travelTime
34 |
35 | spec = describe "Test." $ do
36 | it "test 1" $ destruct tableArea `shouldBe` 3.75
37 | -- it "test 2" $ destruct distance `shouldBe` 300.0
38 |
--------------------------------------------------------------------------------
/Tests/Types/dimensions/test/Spec.hs:
--------------------------------------------------------------------------------
1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-}
2 |
--------------------------------------------------------------------------------
/Tests/XmlParsing/Main.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Text.XML.HaXml
4 | import Text.XML.HaXml.Posn
5 |
6 | -- http://www.kennknowles.com/blog/2008/04/20/using-haxml-to-make-a-pdf-slideshow-from-an-inkscape-svg/
7 | -- http://www.rsdn.ru/article/haskell/haskell_xml.xml
8 |
9 |
10 |
11 | contentAs :: (Content i) -> String
12 | contentAs (CString _ str _) = str
13 |
14 | attributes = [ "events"
15 | , "output"
16 | , "filename"
17 | , "generators"
18 | , "limit"
19 | , "format"
20 | ]
21 |
22 | --attribFilter = foldr keep attributes
23 |
24 | -- o :: CFilter i -> CFilter i -> CFilter i
25 | -- a, b :: CFilter i
26 |
27 | flt = attr "events" `o` attr "output"
28 |
29 | -- foldr :: (a -> b -> b) -> b -> [a] -> b
30 | translate :: Document Text.XML.HaXml.Posn.Posn -> [(String, [String])]
31 | translate (Document _ _ root _) = let
32 | rootElem = CElem root noPos
33 |
34 | logTag = tag "logmap" /> tag "log"
35 |
36 | attributesExtractor a = ((iffind a literal none) `o` logTag) rootElem
37 | thisArgData a = (a, map contentAs (attributesExtractor a))
38 | allArgsData = map thisArgData attributes
39 | in allArgsData
40 |
41 |
42 |
43 | main = do
44 |
45 | content <- readFile "log.xml"
46 |
47 | let xmlDoc = xmlParse "error.log" content
48 |
49 | let myStruct = translate xmlDoc
50 | putStrLn (show myStruct)
51 |
52 | putStrLn "All Ok."
--------------------------------------------------------------------------------
/Tests/XmlParsing/Test.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Text.XML.HaXml
4 | import Text.XML.HaXml.Posn (noPos)
5 |
6 | contentAs :: (Read t) => (Content i) -> t
7 | contentAs cont = read str
8 | where (CString _ str _) = cont
9 |
10 | getList :: String -> [(Float, Float)]
11 | getList cont = zip xpoints ypoints
12 | where
13 | (Document _ _ root _) = xmlParse "error.log" cont
14 | pointFilter = attr "x" `o` attr "y" `o` (tag "letter" /> tag "point")
15 | rootElem = CElem root noPos
16 | xpoints = map (contentAs) (("x" ?) `o` pointFilter $ rootElem)
17 | ypoints = map (contentAs) (("y" ?) `o` pointFilter $ rootElem)
18 |
19 |
20 | main = do
21 | cont <- readFile "test.xml"
22 | let l = getList cont
23 | putStrLn (show l)
--------------------------------------------------------------------------------
/Tests/XmlParsing/log.xml:
--------------------------------------------------------------------------------
1 |
2 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 | ]>
12 |
33 |
34 |
35 |
36 |
37 |
38 |
39 |
40 |
41 |
--------------------------------------------------------------------------------
/Tests/XmlParsing/test.xml:
--------------------------------------------------------------------------------
1 |
2 |
3 |
4 |
5 |
6 |
7 |
8 |
9 |
10 |
11 |
12 |
13 |
14 |
15 |
16 |
17 |
18 |
--------------------------------------------------------------------------------
/Tests/fizzBuzzes.txt:
--------------------------------------------------------------------------------
1 | ["1","2","Fizz","4","Buzz","Fizz","7","8","Fizz","Buzz","11","Fizz","13","14","FizzBuzz","16","17","Fizz","19","Buzz","Fizz","22","23","Fizz","Buzz","26","Fizz","28","29","FizzBuzz","31","32","Fizz","34","Buzz","Fizz","37","38","Fizz","Buzz","41","Fizz","43","44","FizzBuzz","46","47","Fizz","49","Buzz","Fizz","52","53","Fizz","Buzz","56","Fizz","58","59","FizzBuzz","61","62","Fizz","64","Buzz","Fizz","67","68","Fizz","Buzz","71","Fizz","73","74","FizzBuzz","76","77","Fizz","79","Buzz","Fizz","82","83","Fizz","Buzz","86","Fizz","88","89","FizzBuzz","91","92","Fizz","94","Buzz","Fizz","97","98","Fizz","Buzz"]
--------------------------------------------------------------------------------
/Tests/myName.txt:
--------------------------------------------------------------------------------
1 | sdafsdf
--------------------------------------------------------------------------------
/Tests/taggedSymbols.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/taggedSymbols.html
--------------------------------------------------------------------------------
/Tests/taggedSymbols.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/taggedSymbols.txt
--------------------------------------------------------------------------------
/Tests/taggedSymbols2.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/taggedSymbols2.html
--------------------------------------------------------------------------------
/Tests/taggedSymbols3.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/taggedSymbols3.html
--------------------------------------------------------------------------------
/Tests/taggedSymbols4.html:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/taggedSymbols4.html
--------------------------------------------------------------------------------
/Tests/test.txt:
--------------------------------------------------------------------------------
1 | (Sun Apr 10 10:00:00 UTC 2011, 1.21, 1.22, 1.21, 1.22, 1600)
2 | (Sun Apr 10 11:00:00 UTC 2011, 1.24, 1.26, 1.23, 1.26, 3500)
3 | (Sun Apr 10 12:00:00 UTC 2011, 1.25, 1.25, 1.25, 1.25, 300)
4 | (Sun Apr 10 13:00:00 UTC 2011, 1.22, 1.23, 1.22, 1.23, 2200)
5 | (Sun Apr 10 14:00:00 UTC 2011, 1.24, 1.22, 1.22, 1.25, 5200)
6 | (Sun Apr 10 15:00:00 UTC 2011, 1.22, 1.22, 1.22, 1.22, 200)
7 | (Sun Apr 10 16:00:00 UTC 2011, 1.24, 1.24, 1.24, 1.24, 400)
8 | (Sun Apr 10 17:00:00 UTC 2011, 1.33, 1.33, 1.33, 1.33, 544)
9 | (Sun Apr 10 18:00:00 UTC 2011, 1.35, 1.35, 1.35, 1.35, 1500)
10 | (Sun Apr 10 19:00:00 UTC 2011, 1.21, 1.21, 1.21, 1.21, 1210)
11 | (Sun Apr 10 20:00:00 UTC 2011, 1.19, 1.19, 1.19, 1.19, 778)
12 | (Sun Apr 10 21:00:00 UTC 2011, 1.16, 1.16, 1.16, 1.16, 512)
13 | (Sun Apr 10 22:00:00 UTC 2011, 1.28, 1.28, 1.28, 1.28, 1445)
14 | (Sun Apr 10 23:00:00 UTC 2011, 1.29, 1.29, 1.29, 1.29, 2144)
15 |
--------------------------------------------------------------------------------
/Tests/text.txt:
--------------------------------------------------------------------------------
https://raw.githubusercontent.com/graninas/Haskell-Algorithms/ea33607b3af50d5df09513ed9e99a9faa712f57b/Tests/text.txt
--------------------------------------------------------------------------------
/Tests/tree.txt:
--------------------------------------------------------------------------------
1 | Node (Node (Node Tip 1 Tip) 3 (Node Tip 4 Tip)) 5 (Node Tip 7 Tip)
--------------------------------------------------------------------------------