├── .gitignore ├── HINTS.md ├── README.md ├── data └── words ├── week1 ├── README.md ├── logic-brute │ ├── alviprofluvium │ │ └── Main.hs │ ├── balac │ │ └── solve.hs │ ├── neongreen │ │ ├── Main.hs │ │ └── minified.hs │ └── vitcra │ │ └── Main.hs ├── reposts │ ├── balac │ │ └── solve.hs │ ├── boccato │ │ └── Main.hs │ ├── borboss366 │ │ └── Main.hs │ ├── callmecabman │ │ └── Main.hs │ ├── jasonkuhrt │ │ ├── Main.hs │ │ ├── reposts.cabal │ │ └── stack.yaml │ ├── kirikaza │ │ ├── Reposts.hs │ │ ├── Setup.hs │ │ ├── reposts.cabal │ │ ├── stack.yaml │ │ └── try.sh │ ├── neongreen │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── scary │ ├── 444c43 │ │ └── Main.hs │ ├── alviprofluvium │ │ └── Main.hs │ ├── avatar29A │ │ └── Main.hs │ ├── balac │ │ └── solve.hs │ ├── boccato │ │ └── Main.hs │ ├── borboss366 │ │ └── Main.hs │ ├── callmecabman │ │ └── Main.hs │ ├── jasonkuhrt │ │ └── Main.hs │ ├── jonaprieto │ │ └── Main.hs │ ├── kirikaza │ │ ├── Scary.hs │ │ ├── Setup.hs │ │ ├── scary.cabal │ │ ├── stack.yaml │ │ └── try.sh │ ├── knikel │ │ ├── Scary.hs │ │ └── ScaryTests.hs │ ├── lukvol │ │ └── Main.hs │ ├── maverickchaser │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ ├── sth-fish │ │ └── Main.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── tictactoe │ ├── avatar29A │ │ └── tictac │ │ │ ├── LICENSE │ │ │ ├── Setup.hs │ │ │ ├── app │ │ │ └── Main.hs │ │ │ ├── src │ │ │ ├── Draw.hs │ │ │ └── Game.hs │ │ │ ├── stack.yaml │ │ │ ├── test │ │ │ └── Spec.hs │ │ │ └── tictac.cabal │ ├── balac │ │ └── solve.hs │ ├── callmecabman │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs └── wilson │ ├── balac │ └── solve.hs │ ├── jonaprieto │ └── Wilson.hs │ ├── neongreen │ └── Main.hs │ └── vitcra │ └── Main.hs ├── week2 ├── README.md ├── bigint │ ├── balac │ │ ├── BigInt.hs │ │ └── BigIntSpec.hs │ └── neongreen │ │ ├── LICENSE │ │ ├── Setup.hs │ │ ├── bigint.cabal │ │ ├── src │ │ └── BigInt.hs │ │ ├── stack.yaml │ │ └── test │ │ ├── BigIntSpec.hs │ │ └── Spec.hs ├── compress │ ├── alviprofluvium │ │ └── Main.hs │ ├── balac │ │ └── solve.hs │ ├── jasonkuhrt │ │ ├── compress.cabal │ │ ├── source │ │ │ └── Compress.hs │ │ ├── stack.yaml │ │ └── test │ │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── jpath │ ├── balac │ │ ├── solve.hs │ │ └── store.js │ └── neongreen │ │ ├── jp.hs │ │ └── store.js ├── mergesort │ ├── 444c43 │ │ └── Main.hs │ ├── alviprofluvium │ │ └── Main.hs │ ├── balac │ │ └── solve.hs │ ├── callmecabman │ │ └── Main.hs │ ├── jasonkuhrt │ │ └── Main.hs │ ├── neongreen │ │ └── Merge.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs └── shuffle │ ├── balac │ └── solve.hs │ └── neongreen │ └── Main.hs ├── week3 ├── README.md ├── average │ ├── 444c43 │ │ └── Main.hs │ ├── alviprofluvium │ │ └── Main.hs │ ├── aneksteind │ │ └── average.hs │ ├── balac │ │ └── solve.hs │ ├── jasonkuhrt │ │ └── Main.hs │ ├── kirikaza │ │ ├── Average.hs │ │ ├── Setup.hs │ │ ├── average.cabal │ │ ├── stack.yaml │ │ └── try.sh │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── binary │ ├── 444c43 │ │ └── Main.hs │ ├── alviprofluvium │ │ └── Main.hs │ ├── aneksteind │ │ └── binary.hs │ ├── balac │ │ └── solve.hs │ ├── boccato │ │ └── Main.hs │ ├── jasonkuhrt │ │ ├── BinaryConversion.cabal │ │ ├── Main.hs │ │ └── stack.yaml │ ├── neongreen │ │ └── Main.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── expr │ ├── alviprofluvium │ │ └── Expr.hs │ ├── aneksteind │ │ └── expr.hs │ ├── balac │ │ └── solve.hs │ ├── jasonkuhrt │ │ └── Main.hs │ ├── maverickchaser │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── table │ ├── alviprofluvium │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ ├── thalesmg │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs └── xor │ ├── alviprofluvium │ └── Main.hs │ ├── balac │ └── Main.hs │ ├── jasonkuhrt │ ├── Main.hs │ ├── stack.yaml │ └── xor.cabal │ ├── thalesmg │ ├── Main.hs │ └── test │ └── vitcra │ └── Main.hs ├── week4 ├── README.md ├── json-print │ ├── jasonkuhrt │ │ └── Main.hs │ ├── neongreen │ │ └── Main.hs │ └── thalesmg │ │ └── Main.hs ├── justify │ ├── int-index │ │ └── Main.hs │ ├── jasonkuhrt │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs ├── path │ ├── neongreen │ │ └── Main.hs │ ├── thalesmg │ │ ├── Main.hs │ │ ├── sample1 │ │ └── sample2 │ └── vitcra │ │ └── Main.hs ├── spiral │ ├── aneksteind │ │ └── spiral.hs │ ├── balac │ │ └── Main.hs │ ├── jasonkuhrt │ │ ├── Main.hs │ │ ├── spiral.cabal │ │ └── stack.yaml │ ├── neongreen │ │ └── Main.hs │ └── vitcra │ │ └── Main.hs └── trie │ ├── jasonkuhrt │ └── Main.hs │ ├── stites │ └── Main.hs │ └── thalesmg │ └── Main.hs ├── week5 ├── README.md └── quine │ ├── Main.hs │ ├── jasonkuhrt │ └── Main.hs │ ├── neongreen │ └── Main.hs │ ├── thalesmg │ └── Main.hs │ └── vitcra │ └── Main.hs └── week6 └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.exe 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | *.prof 11 | *.aux 12 | *.hp 13 | .virtualenv 14 | .hsenv 15 | .hpc 16 | .stack-work/ 17 | .cabal-sandbox/ 18 | cabal.sandbox.config 19 | cabal.config 20 | TAGS 21 | .DS_Store 22 | *~ 23 | *# 24 | next/ 25 | -------------------------------------------------------------------------------- /HINTS.md: -------------------------------------------------------------------------------- 1 | # Hints 2 | 3 | ## reposts 4 | 5 | You can assume that sister's reposts have numbers 1–N, then then generate 7 random numbers between 1 and 1000000+N and check that at least one of them is between 1 and N. Make sure that generated numbers aren't equal. 6 | 7 | ## logic-brute 8 | 9 | “I knew you didn't know” means that in every possible world consistent with what S knows about the numbers, there are several possible worlds for P. For instance, let's say that the numbers are 4 and 4. The possible worlds for S are (A=6, B=2), (A=5, B=3), and (A=4, B=4). In the case of (6,2) P wouldn't know the numbers, because 12 (i.e. the only thing that P knows) can mean both 6×2 and 4×3. However, in the case of (5,3) P would know the numbers (because only (5,3) gives 15). Hence, S can't be sure that P doesn't know the numbers. Therefore, the numbers aren't (4,4). 10 | 11 | The problem can be solved in this fashion by checking all possible pairs. 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell exercises 2 | 3 | ## What is it 4 | 5 | These are exercises for the Alpha study group (if you want to participate, first get into the [Haskell Learning Group](https://github.com/haskell-learning-group/haskell-learning-group) and then ask @neongreen). A new set is published every week, but you're encouraged to solve old sets too. If you can't solve a task, ask in the Slack channel and you'll be given hints. 6 | 7 | The exercises are beginner-to-intermediate level. Expect to learn how to write algorithms, solve simple problems with Haskell, use common libraries, write sites, talk to databases, create interfaces, parse things, do weird type-level stuff, and more. 8 | 9 | ## Workflow 10 | 11 | ### Submitting Solutions 12 | 13 | 1. **Setup your namespace** 14 | 15 | For instance, if your Github handle is **john** and you are solving task **table** from **week 3**, create a branch called `table/john` and put your solution into `week3/table/john`: 16 | 17 | ``` 18 | $ git checkout -b table/john 19 | $ mkdir -p week3/table/john 20 | ``` 21 | 22 | Recap: 23 | 1. Branch `/` 24 | 2. Folder `week//` 25 | 26 | 1. **Author your solution, get feedback** 27 | 28 | Work in your namespace. It doesn't matter what you call your `.hs` file, but `Main.hs` is a good default. 29 | 30 | Create a pull request once you want feedback on your code and/or are ready to submit it. 31 | 32 | * _Suggestion_ If you are not done then consider writing a [task list](https://github.com/blog/1375-task-lists-in-gfm-issues-pulls-comments) in the description. This convention transparently communicates your progress. 33 | 34 | * _Suggestion_ Feedback will probably result in additional tasks to do so updating the list may be desirable, but then again certain tasks may not be worth such detail. Use judgement, whatever helps. 35 | 36 | 1. **Iterate** 37 | 38 | Discuss feedback with the reviewer. Integrate changes into your solution. Repeat as needed. 39 | 40 | 1. **Finish** 41 | 42 | Once you and your reviewer are satisfied with your solution, merge! From then on you can make changes to your solution's code in the `master` branch (refactors, etc.). 43 | 44 | ### Weekly Review 45 | 46 | At the end of each week each exercise is explained by someone who has solved it. 47 | 48 | ### Stuff that you should know if you're already in 49 | 50 | * Don't forget to use [hlint](https://github.com/ndmitchell/hlint) on your code – it often gives good suggestions on how to improve it. (They aren't *always* good, however! If you're unsure, ask.) 51 | 52 | * You can see yours (and others') progress in [this table](https://docs.google.com/spreadsheets/d/1PEF7K42M-cq1XgiAaqwf-XLeJP2wo3Dc8pU3SsD_R8s/edit?usp=sharing). 53 | 54 | ## Exercises 55 | 56 | * [**Week 6 (October 11–16)**](week6) 57 | 58 | * 23. Write QuickCheck `{quickcheck}` 59 | * 24. Choosing a serialization method `{serialize}` 60 | 61 | * [Week 5 (October 3–9)](week5) 62 | 63 | * 21. Write a quine `{quine}` 64 | * 22. Write a database engine `{db}` 65 | 66 | * [Week 4 (September 19 – October 2)](week4) 67 | 68 | * 16. Draw a spiral `{spiral}` 69 | * 17. Justify text `{justify}` 70 | * 18. Trie `{trie}` 71 | * 19. Path finding `{path}` 72 | * 20. JSON printing `{json-print}` 73 | 74 | * [Week 3 (September 12–18)](week3) 75 | 76 | * 11. Binary conversion `{binary}` 77 | * 12. Working with expressions `{expr}` 78 | * 13. Compute a moving average `{average}` 79 | * 14. XOR encryption `{xor}` 80 | * 15. Table formatting `{table}` 81 | 82 | * [Week 2 (September 5–11)](week2) 83 | 84 | * 6. Merge sort `{mergesort}` 85 | * 7. Silly compression `{compress}` 86 | * 8. Big integers `{bigint}` 87 | * 9. Biased shuffle `{shuffle}` 88 | * 10. JSON extractor `{jpath}` 89 | 90 | * [Week 1 (August 26 – September 4)](week1) 91 | 92 | * 1. Find scary words `{scary}` 93 | * 2. Calculate probability of winning using simulation `{reposts}` 94 | * 3. Write a tic-tac-toe game `{tictactoe}` 95 | * 4. Generate a maze using Wilson's algorithm `{wilson}` 96 | * 5. Solve a logic problem using brute-force `{logic-brute}` 97 | -------------------------------------------------------------------------------- /week1/README.md: -------------------------------------------------------------------------------- 1 | ## Week 1 (August 26 – September 4) 2 | 3 | ### 1. Find scary words `{scary}` 4 | 5 | If you assign numbers to letters (A=1, B=2, ..., Z=26), then a word is scary if the sum of its letters is 13. “baaed”, for instance, is scary (especially when at first you don't understand it's a silly verb and think it's an ancient god's name). 6 | 7 | Find all scary words in the `words` file (it's usually in `/usr/share/dict/words` or `/usr/dict/words`). If you're on Windows, you can [download it](https://raw.githubusercontent.com/eneko/data-repository/master/data/words.txt). 8 | 9 | Common mistakes: 10 | 11 | * Treating `zip's` as scary (the mistake is in assigning a numbers to *all* characters, not just non-letter ones, and then `'` usually gets a negative code). 12 | 13 | * Treating `Iraq` as scary (uppercase characters should be treated the same as lowercase ones). 14 | 15 | ### 2. Calculate probability of winning using simulation `{reposts}` 16 | 17 | There's a contest going on in a Russian social network: seven prizes will be given to seven randomly chosen people among those who have reposted a certain post. (There are actually 100 prizes, but the other 93 suck, so we'll ignore them.) There are already ~1000000 reposts. My sister wonders: what's the probability of her winning at least one prize (out of those seven) if she reposts the post 10 times (from different accounts)? What about 100 times? 1000 times? 18 | 19 | Calculate the answer by running a simulation some number of times (for instance, 10000 times). You can use [`System.Random`](https://hackage.haskell.org/package/random/docs/System-Random.html) or some other random library (e.g. [`Data.Random`](https://hackage.haskell.org/package/random-fu/docs/Data-Random.html)). 20 | 21 | If you're not good at probabilistic simulations, [here's a hint](../HINTS.md#reposts). 22 | 23 | ### 3. Write a tic-tac-toe game `{tictactoe}` 24 | 25 | Here's a sample log that the player should see (Github might be rendering box characters weirdly but they will look okay in terminal): 26 | 27 | ~~~ 28 | A B C 29 | ┏━┯━┯━┓ 30 | 1┃ │ │ ┃ 31 | ┠─┼─┼─┨ 32 | 2┃ │ │ ┃ 33 | ┠─┼─┼─┨ 34 | 3┃ │ │ ┃ 35 | ┗━┷━┷━┛ 36 | 37 | Your move: 38 | > A1 39 | 40 | A B C 41 | ┏━┯━┯━┓ 42 | 1┃X│ │ ┃ 43 | ┠─┼─┼─┨ 44 | 2┃ │O│ ┃ 45 | ┠─┼─┼─┨ 46 | 3┃ │ │ ┃ 47 | ┗━┷━┷━┛ 48 | 49 | Your move: 50 | > B2 51 | 52 | This cell is already taken! 53 | 54 | Your move: 55 | > B1 56 | 57 | A B C 58 | ┏━┯━┯━┓ 59 | 1┃X│X│O┃ 60 | ┠─┼─┼─┨ 61 | 2┃ │O│ ┃ 62 | ┠─┼─┼─┨ 63 | 3┃ │ │ ┃ 64 | ┗━┷━┷━┛ 65 | 66 | Your move: 67 | > A2 68 | 69 | A B C 70 | ┏━┯━┯━┓ 71 | 1┃X│X│O┃ 72 | ┠─┼─┼─┨ 73 | 2┃X│O│ ┃ 74 | ┠─┼─┼─┨ 75 | 3┃O│ │ ┃ 76 | ┗━┷━┷━┛ 77 | 78 | Computer won. 79 | ~~~ 80 | 81 | Use [ansi-terminal](https://hackage.haskell.org/package/ansi-terminal) to color `X`s green and `O`s – red. 82 | 83 | You can implement any algorithm for computer's moves. Here are some suggestions (ranked from easy to hard): 84 | 85 | * Just make a move into any of the empty cells. 86 | 87 | * A simple heuristic (if the human puts two in a row, block them). 88 | 89 | * Minimax (evaluate all possible boards recursively, pick the move that leads to the situation where no boards are winning for the human). 90 | 91 | * More complicated minimax (even if the human can make a tie at any board, choose the move that would lead to the longest game – what if the human would make a mistake later?). See the “A Perfect but Fatalist Player” section in [this article](http://neverstopbuilding.com/minimax). 92 | 93 | ### 4. Generate a maze using Wilson's algorithm `{wilson}` 94 | 95 | The description of the algorithm is quite accessible: http://weblog.jamisbuck.org/2011/1/20/maze-generation-wilson-s-algorithm. Don't try to make it fast – if it can find a 15×15 maze, it's good enough. 96 | 97 | Here's a sample 10×10 maze: 98 | 99 | ``` 100 | ___________________ 101 | | | |_ _ _|_ | 102 | | | | | | | |_|_ _| 103 | | | _|_|_ ___ _| 104 | | _ ___| _|_ | | 105 | | _|_ | | |_ | 106 | | |_|_|_| | | |_| 107 | |_| | _|_ |___ _| 108 | | | | _ | | ___| 109 | | | |_| _|_ | _| | 110 | |___|_____|_________| 111 | 112 | ``` 113 | 114 | ### 5. Solve a logic problem using brute-force `{logic-brute}` 115 | 116 | Two integer numbers A and B are picked, so that A ≥ B and both numbers are within the range [2, 99]. We tell Mr. P their product (A×B) and Mr. S – their sum (A+B). The following dialog takes place: 117 | 118 | P: I don't know the numbers. 119 | S: I knew you didn't know. I don't know either. 120 | P: Now I know the numbers. 121 | S: Now I know them too. 122 | 123 | Find A and B. If you can't, [here's a hint](../HINTS.md#logic-brute). 124 | 125 | For more info on the topic, see Oleg Kiselyov's [“Representing knowledge about knowledge”](http://okmij.org/ftp/Algorithms.html#mr-s-p). 126 | -------------------------------------------------------------------------------- /week1/logic-brute/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | module LogicBrute where 2 | 3 | import Data.List 4 | 5 | type World = (Int, Int) 6 | 7 | pairs :: [World] 8 | pairs = [(a, b) | a <- [2..99], b <- [2..99], a >= b] 9 | 10 | unique :: [a] -> Bool 11 | unique [_] = True 12 | unique _ = False 13 | 14 | -- P knows A*B 15 | pWorlds :: Int -> [World] 16 | pWorlds x = [(a, b) | (a, b) <- pairs, a*b == x] 17 | 18 | -- S knows A+B 19 | sWorlds :: Int -> [World] 20 | sWorlds x = [(a, b) | (a, b) <- pairs, a+b == x] 21 | 22 | 23 | -- P: I don't know the numbers. 24 | fact1 :: World -> Bool 25 | fact1 (a, b) = (not . unique . pWorlds) (a*b) 26 | 27 | -- S: I knew you didn't know. I don't know either. 28 | fact2 :: World -> Bool 29 | fact2 (a, b) = (not . unique . sWorlds) (a+b) && all fact1 (sWorlds (a+b)) 30 | 31 | -- P: Now I know the numbers 32 | fact3 :: World -> Bool 33 | fact3 (a, b) = unique . filter fact2 $ pWorlds (a*b) 34 | 35 | -- S: Now I know them too. 36 | fact4 :: World -> Bool 37 | fact4 (a, b) = unique . filter fact3 $ sWorlds (a+b) 38 | 39 | solutions :: [World] 40 | solutions = filter (\x -> all ($x) [fact1, fact2, fact3, fact4]) pairs 41 | 42 | main :: IO () 43 | main = print solutions 44 | -------------------------------------------------------------------------------- /week1/logic-brute/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import GHC.Exts 2 | import Data.List 3 | 4 | allNums = [2..99] :: [Int] 5 | 6 | type Choice= (Int,Int) 7 | type Space = [Choice] 8 | 9 | -- Slice of space such that all Choices in them have the same projection along a particular dimension. 10 | -- The common value of the projection is the `fst` element. 11 | type Slice = (Int,Space) 12 | 13 | univ :: Space 14 | univ = [ ( x, y ) | x <- allNums, y <- allNums, x >= y ] 15 | 16 | isUnique :: Slice -> Bool 17 | isUnique (_,xs) = length xs == 1 18 | 19 | isValueIn :: [Int] -> Slice -> Bool 20 | isValueIn xs (value,_) = value `elem` xs 21 | 22 | cSum :: Choice -> Int 23 | cSum (x,y) = x + y 24 | 25 | cProduct :: Choice -> Int 26 | cProduct (x,y) = x * y 27 | 28 | split :: (Choice->Int) -> (Slice->Bool) -> Space -> (Space,Space) 29 | split proj predicate space = ( matches, remainder ) 30 | where 31 | slices = map (\lst -> ( proj ( head lst ), lst ) ) $ groupWith proj space 32 | matchingSlices = filter predicate slices 33 | matches = concatMap snd matchingSlices 34 | remainder = space \\ matches 35 | 36 | ( uniqProds, s1 ) = split cProduct isUnique univ 37 | ( _, s2 ) = split cSum ( isValueIn $ map cSum uniqProds ) s1 38 | ( s3, _ ) = split cProduct isUnique s2 39 | ( s4, _ ) = split cSum isUnique s3 40 | 41 | solution = head s4 42 | 43 | main = print solution -------------------------------------------------------------------------------- /week1/logic-brute/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | type World = (Int, Int) 2 | 3 | worlds :: [World] 4 | worlds = [(a,b) | a <- [2..99], b <- [2..99], a>=b] 5 | 6 | -- Faster than “length xs > 1” 7 | ambiguous :: [World] -> Bool 8 | ambiguous (x:y:_) = True 9 | ambiguous xs = False 10 | 11 | unambiguous :: [World] -> Bool 12 | unambiguous [x] = True 13 | unambiguous xs = False 14 | 15 | -- All worlds in which the product is X. 16 | pWorlds :: Int -> [World] 17 | pWorlds p = [(a,b) | (a,b) <- worlds, a*b == p] 18 | 19 | -- All worlds in which the sum is X. 20 | sWorlds :: Int -> [World] 21 | sWorlds s = [(a,b) | (a,b) <- worlds, a+b == s] 22 | 23 | -- | Line 1: P doesn't know the numbers. 24 | line1 :: World -> Bool 25 | line1 (a,b) = 26 | -- If actual numbers are (a,b), then with what P knows it's impossible to 27 | -- determine the numbers unambiguously 28 | ambiguous (pWorlds p) 29 | where 30 | p = a*b 31 | 32 | -- | Line 2: S knows that P doesn't know the numbers, and S doesn't know the 33 | -- numbers either. 34 | line2 :: World -> Bool 35 | line2 (a,b) = 36 | -- S doesn't know the numbers 37 | ambiguous (sWorlds s) && 38 | -- S knows that P doesn't know the numbers, i.e. line 1 is true for *all* 39 | -- possible worlds 40 | all line1 (sWorlds s) 41 | where 42 | s = a+b 43 | 44 | -- | Line 3: now that P knows information from line 2, P knows the numbers. 45 | line3 :: World -> Bool 46 | line3 (a,b) = 47 | -- There's only one world that is consistent with what P knows (i.e. the 48 | -- product) and in which line2 holds 49 | unambiguous (filter line2 (pWorlds p)) 50 | where 51 | p = a*b 52 | 53 | -- | Line 4: now that S knows information from line 3, S knows the numbers. 54 | line4 :: World -> Bool 55 | line4 (a,b) = 56 | -- There's only one world that is consistent with what S knows (i.e. the 57 | -- sum) and in which line3 holds 58 | unambiguous (filter line3 (sWorlds s)) 59 | where 60 | s = a+b 61 | 62 | main = print $ filter (\x -> all ($x) [line1,line2,line3,line4]) worlds 63 | -------------------------------------------------------------------------------- /week1/logic-brute/neongreen/minified.hs: -------------------------------------------------------------------------------- 1 | worlds = [(a,b) | a <- [2..99], b <- [2..99], a>=b] 2 | 3 | ambiguous (x:y:_) = True 4 | ambiguous xs = False 5 | 6 | unambiguous [x] = True 7 | unambiguous xs = False 8 | 9 | pWorlds p = [(a,b) | a <- [2..min p 99], let b = div p a, a>=b, b>=2, a*b==p] 10 | sWorlds s = [(a,b) | a <- [2..s], let b = s-a, a>=b, b>=2] 11 | 12 | line1 (a,b) = ambiguous (pWorlds (a*b)) 13 | line2 (a,b) = ambiguous (sWorlds (a+b)) && all line1 (sWorlds (a+b)) 14 | line3 (a,b) = unambiguous (filter line2 (pWorlds (a*b))) 15 | line4 (a,b) = unambiguous (filter line3 (sWorlds (a+b))) 16 | 17 | main = print $ filter (\x -> all ($x) [line1,line2,line3,line4]) worlds 18 | -------------------------------------------------------------------------------- /week1/logic-brute/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | 5 | type Pair = (Int, Int) 6 | 7 | factorPairs :: Int -> [Pair] 8 | factorPairs n = [(a,b) | a <- [2..div n 2], (b, 0) <- [divMod n a], a >= b] 9 | 10 | termPairs :: Int -> [Pair] 11 | termPairs n = [(n-b, b) | b <- [2..div n 2]] 12 | 13 | pTs :: [Pair] -> [[Pair]] 14 | pTs = map (\(a, b) -> termPairs $ a+b) 15 | 16 | sTp :: [Pair] -> [[Pair]] 17 | sTp = map (\(a, b) -> factorPairs $ a*b) 18 | 19 | -- definitely cannot know 20 | knowNot :: [Pair] -> Bool 21 | knowNot ps = length ps > 1 22 | 23 | -- I know you do not know 24 | sKnowKnowNot :: [Pair] -> Bool 25 | sKnowKnowNot ts = all knowNot $ sTp ts 26 | 27 | pKnows :: [Pair] -> Bool 28 | pKnows fs = 1 == length ns where 29 | ns = filter sKnowKnowNot $ pTs fs 30 | 31 | sKnows :: [Pair] -> Bool 32 | sKnows ts = 1 == length ns where 33 | ns = filter pKnows $ sTp ts 34 | 35 | isSolution :: Pair -> Bool 36 | isSolution (a, b) = 37 | and [knowNot fs 38 | , knowNot ts 39 | , sKnowKnowNot ts 40 | , pKnows fs 41 | , sKnows ts] 42 | where 43 | fs = factorPairs $ a*b 44 | ts = termPairs $ a+b 45 | 46 | main :: IO () 47 | main = do 48 | let (numbers:_) = filter isSolution [(a, b) | a <- [2..99], b <- [2..99], a >= b] 49 | putStrLn $ "The numbers are " ++ show numbers 50 | -------------------------------------------------------------------------------- /week1/reposts/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import System.Random 2 | import System.IO 3 | import Control.Monad 4 | import Data.Function 5 | 6 | kNumExistingPosts = 1000000 :: Int 7 | kNumPosts = [ 10, 100, 1000 ] :: [Int] 8 | kNumWinners = 7 :: Int 9 | kNumTrials = 10000 :: Int 10 | 11 | getNonMember :: [Int] -> Int -> IO Int 12 | getNonMember lst range = head . filter ( `notElem` lst ) . randomRs ( 1, range ) <$> newStdGen 13 | 14 | pickNums :: Int -> Int -> IO [Int] 15 | pickNums count range = foldM (\x y -> liftM2 (:) ( getNonMember x range ) $ return x ) [] [1..count] 16 | 17 | isWin :: Int -> Int -> Int -> IO Bool 18 | isWin numExistingPosts numPosts numWinners = do 19 | let totalPosts = numExistingPosts + numPosts 20 | drawnNums <- pickNums numPosts totalPosts 21 | return $ any ( <= numWinners ) drawnNums 22 | 23 | winProb :: Int -> Int -> Int -> IO Float 24 | winProb numExistingPosts numPosts numTrials = do 25 | results <- replicateM numTrials $ isWin numExistingPosts numPosts kNumWinners 26 | return $ ( (/) `on` fromIntegral ) ( length $ filter id results ) numTrials 27 | 28 | main = do 29 | results <- mapM (\x -> winProb kNumExistingPosts x kNumTrials ) kNumPosts 30 | print results -------------------------------------------------------------------------------- /week1/reposts/boccato/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Data.List 5 | import System.Random 6 | import Text.Printf 7 | 8 | nWinners = 7 9 | nSimulations = 10000 10 | nCurrentReposts = 1000000 11 | 12 | takeDistinct :: Eq a => Int -> [a] -> [a] 13 | takeDistinct n xs = sample n xs [] 14 | where 15 | sample _ [] res = res 16 | sample n (x:xs) res 17 | | n == 0 = res 18 | | x `elem` res = sample n xs res 19 | | otherwise = sample (n-1) xs (x:res) 20 | 21 | -- nWinners are taken from a pool of n+nCurrentReposts tickets 22 | simulate :: Int -> IO Bool 23 | simulate n = do 24 | g <- newStdGen 25 | let nReposts = n + nCurrentReposts 26 | let xs = randomRs(1,nReposts) g 27 | return $ any (<= n) (takeDistinct nWinners xs) 28 | 29 | probability :: Int -> IO Float 30 | probability reposts = do 31 | xs <- replicateM nSimulations $ simulate reposts 32 | let wins = length $ filter (== True) xs 33 | return $ fromIntegral wins / fromIntegral nSimulations * 100 34 | 35 | main :: IO () 36 | main = forM_ [10, 100, 1000, 10000, 100000, 1000000] $ \reposts -> do 37 | p <- probability reposts 38 | printf "Probability of %5.2f%% for %d reposts.\n" p reposts 39 | -------------------------------------------------------------------------------- /week1/reposts/borboss366/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Set (Set, size, insert, fromList, lookupIndex, empty, intersection) 4 | import System.Random (RandomGen, mkStdGen, randomR) 5 | import Numeric (showFFloat) 6 | 7 | insertIndex :: Int -> Set Int -> Int -> Set Int 8 | insertIndex nTotal st value | size st >= nTotal = st -- aready filled all the values 9 | | otherwise = case ind of 10 | Just _ -> insertIndex nTotal st nextValue 11 | Nothing -> insert value st 12 | where ind = lookupIndex value st 13 | nextValue = (value + 1) `mod` nTotal 14 | 15 | insertStep :: RandomGen g => Int -> (Set Int, g) -> (Set Int, g) 16 | insertStep nTotal (st, g) = (insertIndex nTotal st value, g') 17 | where (value, g') = randomR (0, nTotal - 1) g 18 | 19 | generateDistinct :: RandomGen g => g -> Int -> Int -> (Set Int, g) 20 | generateDistinct g nTotal count | nTotal <= 0 || count <= 0 = (empty, g) 21 | | count >= nTotal = (fromList [0..(nTotal - 1)], g) 22 | | otherwise = (st, g') 23 | where (st, g') = iterate (insertStep nTotal) (empty, g) !! count 24 | 25 | calcSuccessProbability :: RandomGen g => g -> Int -> (g -> (Bool, g)) -> (Double, g) 26 | calcSuccessProbability g n f = (fromIntegral s / fromIntegral n, g') 27 | where (s, g') = calcSuccesses g n f 28 | 29 | calcSuccesses :: RandomGen g => g -> Int -> (g -> (Bool, g)) -> (Int, g) 30 | calcSuccesses g 0 f = (0, g) 31 | calcSuccesses g n f 32 | | success = (1 + otherP, g') 33 | | otherwise = (otherP, g') 34 | where (success, newG) = f g 35 | (otherP, g') = calcSuccesses newG (n - 1) f 36 | 37 | makeSimulationSetStep :: RandomGen g => Int -> Int -> Int -> g -> (Bool, g) 38 | makeSimulationSetStep totalPosts winningPosts reposts g = (success, g'') 39 | where (winSet, g') = generateDistinct g totalPosts winningPosts 40 | (repostSet, g'') = generateDistinct g' totalPosts reposts 41 | intSet = intersection repostSet winSet 42 | success = size intSet > 0 43 | 44 | main :: IO () 45 | main = do 46 | print $ "Probability with 10 reposts = " ++ showF prob10 47 | print $ "Probability with 100 reposts = " ++ showF prob100 48 | print $ "Probability with 1000 reposts = " ++ showF prob1000 49 | where g = mkStdGen 239 50 | sn = 1000 51 | f = makeSimulationSetStep 1000000 7 52 | (prob10, g') = calcSuccessProbability g sn (f 10) 53 | (prob100, g'') = calcSuccessProbability g' sn (f 100) 54 | (prob1000, g''') = calcSuccessProbability g'' sn (f 1000) 55 | showF fval = showFFloat Nothing (fval * 100) "" ++ "%" 56 | -------------------------------------------------------------------------------- /week1/reposts/callmecabman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | --import Data.Foldable 4 | import Data.Random 5 | import Data.Function 6 | import Control.Monad 7 | import Text.Printf 8 | 9 | genDiffRandOne :: Int -> [Int] -> RVar Int 10 | genDiffRandOne up rs = do t <- uniform 1 up 11 | if t `notElem` rs 12 | then return t 13 | else genDiffRandOne up rs 14 | 15 | growRandList :: Int -> [Int] -> RVar [Int] 16 | growRandList up rs = do t <- genDiffRandOne up rs 17 | return (t:rs) 18 | 19 | genDiffRandMany :: Int -> Int -> RVar [Int] 20 | -- genDiffRandMany up k = foldlM (\rs _ -> growRandList up rs) [] [1..k] 21 | genDiffRandMany up k = foldr (=<<) (return []) (replicate k (growRandList up)) 22 | 23 | trial :: Int -> RVar Bool 24 | trial n = any (<= n) <$> genDiffRandMany (basePosts + n) winners 25 | 26 | simulateTrials :: Int -> RVar Float 27 | simulateTrials n = do results <- replicateM trialsNum (trial n) 28 | let w = length (filter id results) 29 | return $ ((/) `on` fromIntegral) w trialsNum 30 | 31 | main :: IO () 32 | main = do w <- sample $ forM [10, 100, 1000] simulateTrials 33 | print w 34 | 35 | basePosts :: Int 36 | basePosts = 1000000 37 | 38 | winners :: Int 39 | winners = 7 40 | 41 | trialsNum :: Int 42 | trialsNum = 10000 43 | -------------------------------------------------------------------------------- /week1/reposts/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | -- # Reposts 3 | 4 | -- Question: 5 | -- seven prizes will be given to seven randomly chosen people among those who 6 | -- have reposted a certain post. There are already ~1,000,000 reposts. 7 | -- My sister wonders: what's the probability of her winning at least one prize 8 | -- (out of those seven) if she reposts the post 10 times 9 | -- (from different accounts)? What about 100 times? 1000 times? 10 | 11 | -- Notes: 12 | -- Calculate the answer by running a simulation some number of times 13 | -- (for instance, 10000 times). You can use System.Random or some other 14 | -- random library (e.g. Data.Random). 15 | 16 | 17 | module Main where 18 | 19 | import qualified Data.List as List 20 | import qualified System.Random as Random 21 | import qualified Text.Printf as Print 22 | import qualified Control.Monad as Monad 23 | 24 | 25 | 26 | -- * Pick values for three variables: 27 | -- * a total repost count A 28 | -- * count of winners drawn B 29 | -- * Bob's count of reposts C 30 | -- * Imagine that reposts can be identified by their index in the repost count 31 | -- * Now select winners by randomly generating B indexes in range of A 32 | -- * Now Check how many winners are between 1-C. Yes this assumes that Bob 33 | -- has a contiguous serious of reposts beginning at the head of list A. 34 | -- However! This unlikely detail is inconsequential for the purposes of 35 | -- calculating the probability of Bob being amongst the winners. 36 | -- 37 | -- TODO Parallel Approach (credit for idea is @neongreen) 38 | -- 39 | -- Observation 1 40 | -- If you have some winners and you want to check whether any 41 | -- of them won, you just have to check whether the lowest one won. 42 | -- 43 | -- Observation 2 44 | -- If you know the lowest winner, you can check whether it's less than 45 | -- 10/100/1000 and get 3 booleans (would be simpler to implement as 3 Ints) 46 | -- 47 | -- So... 48 | -- Then you just sum up 10000 of those triples and get 3 answers 49 | -- simultaneously! 50 | 51 | 52 | 53 | type Winners = [Int] 54 | data DrawOutcome = Lost | Won deriving (Show,Eq) 55 | 56 | 57 | 58 | data Experiment = Experiment { 59 | prizeCount :: Int, 60 | repostCount :: Int, 61 | myReposts :: Int 62 | } deriving (Show) 63 | 64 | 65 | 66 | -- Report on several experiments varying by how many times I repost. 67 | 68 | main :: IO () 69 | main = do 70 | printChanceIfmyReposts 10 71 | printChanceIfmyReposts 100 72 | printChanceIfmyReposts 1000 73 | where 74 | printChanceIfmyReposts n = do 75 | let e = Experiment { myReposts = n, repostCount = 1000000, prizeCount = 7 } 76 | Print.printf 77 | "Given %s\nthe probability of winning is %F%%.\n\n" 78 | (show e) 79 | (myChanceIf e) 80 | 81 | 82 | 83 | -- Run an experiment many times and then calculate how likely I am to win. 84 | 85 | myChanceIf :: Experiment -> Double 86 | myChanceIf experiment = probability 87 | where 88 | 89 | probability = realToFrac winCount / realToFrac iterations * 100 90 | winCount = length . filter (== Won) . runExperimentTimes experiment $ iterations 91 | iterations = 100000 92 | 93 | runExperimentTimes :: Experiment -> Int -> [DrawOutcome] 94 | runExperimentTimes experiment numOfRuns = 95 | List.unfoldr go (1, Random.split (Random.mkStdGen 1)) 96 | where 97 | go (runNum, (g1,g2)) 98 | | runNum > numOfRuns = Nothing 99 | | otherwise = Just ( 100 | runExperiment g1 experiment, 101 | (runNum + 1, Random.split g2) 102 | ) 103 | 104 | 105 | 106 | -- Run an experiment showing if I win or lose. 107 | 108 | runExperiment :: Random.RandomGen g => g -> Experiment -> DrawOutcome 109 | runExperiment generator Experiment{..} = 110 | boolToOutcome . 111 | any (<= myReposts) . 112 | take prizeCount . 113 | List.nub . -- Avoid duplicates. May arise since random... 114 | Random.randomRs (1, repostCount) 115 | $ generator 116 | 117 | 118 | 119 | boolToOutcome :: Bool -> DrawOutcome 120 | boolToOutcome True = Won 121 | boolToOutcome False = Lost 122 | 123 | countUnique :: Eq a => [a] -> Int 124 | countUnique = length . List.nub 125 | -------------------------------------------------------------------------------- /week1/reposts/jasonkuhrt/reposts.cabal: -------------------------------------------------------------------------------- 1 | name: reposts 2 | version: 0.1.0.0 3 | synopsis: Initial project template from stack 4 | description: Please see README.md 5 | homepage: https://github.com/jasonkuhrt/reposts#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Jason Kuhrt 9 | maintainer: jasonkuhrt@me.com 10 | copyright: ISC 11 | category: App 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | executable reposts-exe 17 | hs-source-dirs: . 18 | main-is: Main.hs 19 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 20 | build-depends: base 21 | , random 22 | default-language: Haskell2010 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/jasonkuhrt/reposts 27 | -------------------------------------------------------------------------------- /week1/reposts/jasonkuhrt/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 | # http://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-6.14 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.1" 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 -------------------------------------------------------------------------------- /week1/reposts/kirikaza/Reposts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Main where 4 | 5 | import Control.Monad (forM, forM_, replicateM) 6 | import Data.Function (on) 7 | import Data.Monoid ((<>)) 8 | import Data.Random (RVar, runRVar, sampleState, uniform) 9 | import Numeric (showFFloat) 10 | import System.Random (StdGen, getStdRandom) 11 | 12 | main :: IO () 13 | main = forM_ [10, 100, 1000] $ \sisterReposts -> do 14 | let totalReposts = 1000000 15 | gifts = 7 16 | repetitions = 10000 17 | contest = simContest totalReposts sisterReposts gifts 18 | repeatContest = repeatSim repetitions contest 19 | results <- getStdRandom . sampleState $ repeatContest 20 | let prob = calcWinProb results 21 | probPercent = prob * 100 22 | probPercentStr = showFFloat (Just 8) probPercent "%" 23 | putStrLn $ "if the sister reposts " <> show sisterReposts <> " times, probability for of her winning is " <> probPercentStr 24 | 25 | repeatSim :: Int -> RVar a -> RVar [a] 26 | repeatSim times sim = replicateM times sim 27 | 28 | calcWinProb :: [Bool] -> Double 29 | calcWinProb results = winsNum /. resultsNum 30 | where winsNum = length $ filter id results 31 | resultsNum = length results 32 | (/.) = (/) `on` fromIntegral 33 | 34 | simContest :: Int -> Int -> Int -> RVar Bool 35 | simContest totalReposts sisterReposts gifts = do 36 | giftsNumbers <- selectNumbers 1 totalReposts gifts 37 | return $ any (<= sisterReposts) giftsNumbers 38 | 39 | selectNumbers :: Int -> Int -> Int -> RVar [Int] 40 | selectNumbers min max count = do 41 | forM [max, max-1 .. max-count+1] $ uniform min 42 | -------------------------------------------------------------------------------- /week1/reposts/kirikaza/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /week1/reposts/kirikaza/reposts.cabal: -------------------------------------------------------------------------------- 1 | name: reposts 2 | version: 0.1.0.0 3 | synopsis: Haskell exercises: Week 1: Task 1: Calculate probability of winning using simulation (by kirikaza) 4 | homepage: https://github.com/neongreen/haskell-ex 5 | author: Kirill Kazakov 6 | maintainer: k@kirikaza.ru 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable reposts 11 | hs-source-dirs: . 12 | main-is: Reposts.hs 13 | default-language: Haskell2010 14 | build-depends: base >= 4.7 && < 5 15 | , random 16 | , random-fu -------------------------------------------------------------------------------- /week1/reposts/kirikaza/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.4 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /week1/reposts/kirikaza/try.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | set -e 4 | cd "$(dirname "$0")" 5 | exec stack runghc Reposts.hs 6 | -------------------------------------------------------------------------------- /week1/reposts/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Foldable 2 | import Control.Monad 3 | import System.Random 4 | import Data.List 5 | import Text.Printf 6 | 7 | -- | Generate 'n_winners' random winners. 8 | randomWinners 9 | :: Int -- ^ Total entries 10 | -> IO [Int] 11 | randomWinners range = do 12 | ns <- replicateM n_winners (randomRIO (1,range)) 13 | if length (nub ns) < n_winners then randomWinners range else return ns 14 | 15 | -- | Simulate one draw by generating some winners and checking whether any of 16 | -- our reposts won. 17 | trial 18 | :: Int -- ^ Amount of reposts that are ours 19 | -> IO Bool 20 | trial reposts = any (<= reposts) <$> randomWinners (n_entries + reposts) 21 | 22 | main :: IO () 23 | main = for_ [10, 100, 1000] $ \reposts -> do 24 | -- Simulate some trials 25 | results <- replicateM n_trials (trial reposts) 26 | -- How many of those were successful? 27 | let success = length (filter id results) 28 | -- So, what's the total probability of success? 29 | let prob = fromIntegral success / fromIntegral n_trials :: Double 30 | -- Print it (as a percentage) 31 | printf "for %4d reposts, the probability of winning is %.3f%%\n" 32 | reposts (prob*100) 33 | 34 | -- Constants 35 | 36 | n_entries = 1000000 37 | n_winners = 7 38 | n_trials = 10000 39 | -------------------------------------------------------------------------------- /week1/reposts/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import System.Random 5 | import Data.Set (Set) 6 | import qualified Data.Set as Set 7 | 8 | data Experiment = Experiment {my::Int, other::Int, prizes::Int} 9 | 10 | -- returns 0 if we did not win, 1 if we did 11 | draw :: RandomGen g => g -> Experiment -> (Int, g) 12 | draw g Experiment{..} = (min 1 . hits . fst $ rs, snd rs) where 13 | hits = Set.size . Set.filter (<= my) 14 | rs = helper g prizes Set.empty 15 | helper g 0 xs = (xs, g) 16 | helper g n xs = 17 | if Set.member r xs 18 | then helper g' n xs 19 | else helper g' (n-1) (Set.insert r xs) 20 | where 21 | (r, g') = randomR (1, my + other) g 22 | 23 | repeatDraw :: RandomGen g => g -> Int -> Experiment -> [Int] 24 | repeatDraw g n e = helper g n [] where 25 | helper g 0 xs = xs 26 | helper g n xs = helper g' (n-1) (d:xs) where 27 | (d, g') = draw g e 28 | 29 | 30 | otherReposts = 1000000 31 | sampleSize = 10000 32 | nrPrizes = 7 33 | 34 | myChanceIf :: Int -> IO () 35 | myChanceIf n = do 36 | g <- newStdGen 37 | let 38 | e = Experiment {my=n, other=otherReposts, prizes=nrPrizes} 39 | results = repeatDraw g sampleSize e 40 | probability = fromIntegral (sum results) / fromIntegral sampleSize 41 | putStrLn $ "For " ++ show n ++ " reposts your chance is " ++ show probability 42 | 43 | main :: IO () 44 | main = do 45 | myChanceIf 10 46 | myChanceIf 100 47 | myChanceIf 1000 48 | -------------------------------------------------------------------------------- /week1/scary/444c43/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.Char 3 | import Data.List 4 | 5 | -- given a string 6 | -- convert the head to a number, if it's a letter 7 | -- subtract the offset and add the value of tail passed to self 8 | sumString :: String -> Int 9 | sumString [] = 0 10 | sumString (x:xs) 11 | | (x `elem` letters) == True = (fromEnum (toLower x) - offset) + sumString xs 12 | | (x `elem` letters) == False = 0 + sumString xs 13 | where letters = ['a'..'z'] ++ ['A'..'Z'] 14 | offset = 96 15 | 16 | -- create a new list with each element of a list whose summed total is 13 17 | parseList :: [String] -> [String] 18 | parseList xs = [ x | x <- xs, sumString x == 13] 19 | 20 | -- read from a file, conver to lines, pass to sumList and print to screen 21 | main = do 22 | contents <- readFile "/usr/share/dict/words" 23 | print . sumList . lines $ contents 24 | -------------------------------------------------------------------------------- /week1/scary/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | scary :: String -> Int 4 | scary = sum . map value 5 | where 6 | value x 7 | | isLetter x && isAscii x = ord (toUpper x) - (ord 'A' - 1) 8 | | otherwise = 0 9 | 10 | isScary :: String -> Bool 11 | isScary xs = scary xs == 13 12 | 13 | main :: IO () 14 | main = do 15 | contents <- readFile "/usr/share/dict/words" 16 | putStr $ unlines $ filter isScary $ words contents 17 | 18 | 19 | -------------------------------------------------------------------------------- /week1/scary/avatar29A/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Char 4 | 5 | getCode :: Char -> Int 6 | getCode ch = 7 | let 8 | zeroIndex = ord 'a' - 1 9 | in 10 | (ord . toLower $ ch) - zeroIndex 11 | 12 | isScary :: String -> Bool 13 | isScary [] = False 14 | isScary s = 15 | sum (map getCode s) == 13 16 | 17 | main :: IO() 18 | main = do 19 | contents <- words <$> readFile "C:\\temp\\words.txt" 20 | putStrLn $ unwords (map addNewLine (filter isScary contents)) 21 | where 22 | addNewLine :: String -> String 23 | addNewLine s = s ++ "\n" 24 | -------------------------------------------------------------------------------- /week1/scary/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.Char 3 | 4 | intVal :: Char -> Int 5 | intVal c = ord ( toLower c ) - 96 6 | 7 | isScary :: [Char] -> Bool 8 | isScary word = sum [ intVal c | c <- word, isAscii c, isLetter c ] == 13 9 | 10 | main = do 11 | contents <- readFile "words.txt" 12 | let words = lines contents 13 | let scaryWords = filter isScary words 14 | print scaryWords 15 | -------------------------------------------------------------------------------- /week1/scary/boccato/Main.hs: -------------------------------------------------------------------------------- 1 | -- stack runghc Main.hs < /usr/share/dict/words 2 | 3 | module Main where 4 | 5 | import Data.Char 6 | 7 | numberOf :: Char -> Int 8 | numberOf c 9 | | isLetter c = ord (toLower c) - ord 'a' + 1 10 | | otherwise = 0 11 | 12 | isScary :: String -> Bool 13 | isScary w = sum (map numberOf w) == 13 14 | 15 | main :: IO () 16 | main = do 17 | ws <- lines <$> getContents 18 | mapM_ putStrLn $ filter isScary ws 19 | -------------------------------------------------------------------------------- /week1/scary/borboss366/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | import Data.Char (toLower, ord, isAsciiLower) 3 | 4 | isScary :: String -> Bool 5 | isScary word = countSum word == 13 6 | 7 | countSum :: String -> Int 8 | countSum = sum . map (\c -> ord c - ord 'a' + 1) . filter isAsciiLower . map toLower 9 | 10 | main :: IO () 11 | main = processFile "/usr/share/dict/words" 12 | 13 | processFile inputFile = do 14 | input <- readFile inputFile 15 | print "Scary words:" 16 | mapM_ print $ filter isScary $ lines input 17 | -------------------------------------------------------------------------------- /week1/scary/callmecabman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | where 3 | 4 | import Data.Char 5 | 6 | scarySum :: String -> Int 7 | scarySum = sum . map (ord' . toLower) 8 | where 9 | ord' c = ord c - ord 'a' + 1 10 | 11 | isScary :: String -> Bool 12 | isScary = (13 ==) . scarySum . filter isLetter 13 | 14 | main :: IO () 15 | main = getContents 16 | >>= return . map isScary . words 17 | >>= print 18 | -------------------------------------------------------------------------------- /week1/scary/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | -- # Scary 2 | 3 | -- Given a letter-to-number mapping, find all "scary" words in the dictionary. 4 | -- The mapping system is A=1, B=2, ..., Z=26. 5 | -- A "scary" word is any word whose sum is 13. 6 | -- The dictionary file can be found at /usr/share/dict/words (macOS) 7 | 8 | 9 | 10 | import qualified Data.Char as Char 11 | import qualified Data.Ix as Range 12 | 13 | 14 | 15 | main :: IO () 16 | main = printScaryDictWords "/usr/share/dict/words" 17 | 18 | 19 | 20 | printScaryDictWords :: String -> IO () 21 | printScaryDictWords dictionaryFilePath = 22 | -- TODO Handle the possible exception thrown by readfile! 23 | -- Refer to suggestion from neongreen: 24 | -- https://haskell-learning.slack.com/archives/alpha/p1472742690000172 25 | print 26 | . filter isScary 27 | -- Optimization: This function expects a list of words sorted alphabetically 28 | -- so that we can stop searching once words are no longer possibly scary 29 | -- (all words after "n", see "isPossiblyScary" for more details). 30 | . takeWhile isPossiblyScary 31 | . words 32 | =<< readFile dictionaryFilePath 33 | 34 | 35 | 36 | isScary :: String -> Bool 37 | isScary = (== scaryNumber) . sum . fmap letterValue 38 | 39 | 40 | 41 | -- Useful for short circuit optimizations: If the word's first character 42 | -- _number_ is beyond the scary number then naturally the word's sum *must* 43 | -- be greater than (importantly to us: _not_) the scary number. 44 | 45 | -- In this program "13" is the scary number which results in any word starting 46 | -- with the letter "m" onward never being scary. 47 | 48 | isPossiblyScary :: String -> Bool 49 | isPossiblyScary "" = False 50 | isPossiblyScary word = (<= scaryNumber) . letterValue . head $ word 51 | 52 | 53 | 54 | scaryNumber :: Int 55 | scaryNumber = 13 56 | 57 | 58 | 59 | letterValue :: Char -> Int 60 | letterValue char 61 | | isEligible charNormalized = calcValue charNormalized 62 | | otherwise = 0 63 | where 64 | isEligible = Range.inRange ('a','z') 65 | charNormalized = Char.toLower char 66 | -- The mapping system is simply A=1, B=2, ... Z=26. We can take advantage of 67 | -- unicode numbers+ordering to provide this mapping because unicode a-z 68 | -- characters are contiguously numbered (97-122)! We just need to subtract 69 | -- by value of our system's first unicode point (minus 1, because we 70 | -- are one-based rather than zero-based) to align our numbering. 71 | calcValue = subtract (Char.ord 'a' - 1) . Char.ord 72 | 73 | -- Alternative implementation: 74 | -- This solution reads better but proved slower by multiple seconds. 75 | -- 76 | -- | isAll [Char.isAscii, Char.isLetter] char = calcValue char 77 | -- | otherwise = 0 78 | -- where 79 | -- calcValue = subtract (Char.ord 'a' - 1) . Char.ord . Char.toLower 80 | -------------------------------------------------------------------------------- /week1/scary/jonaprieto/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE UnicodeSyntax #-} 2 | 3 | module Main 4 | where 5 | 6 | import Data.HashMap.Strict as H (HashMap, fromList, lookupDefault) 7 | import qualified Data.Text as T 8 | 9 | -- To assign the value of each letter, I did a zip between [1,2,3,..] 10 | -- and the other letters. Later, I just ask for this map in O (1) 11 | -- the value. With the lookupDefault 0, I don't worry about if actually 12 | -- it is not a letter. 13 | charset ∷ H.HashMap Char Int 14 | charset = H.fromList $ zip ['A'..'Z'] [1..] 15 | 16 | sumWord ∷ T.Text → Int 17 | sumWord = sum . map (\c → lookupDefault 0 c charset) . T.unpack . T.toUpper 18 | isScary ∷ T.Text → Bool 19 | isScary = (13 ==) . sumWord 20 | 21 | -- I just print the word in case it is actually a scary word. 22 | main ∷ IO () 23 | main = putStr 24 | . T.unpack 25 | . T.unlines 26 | . filter isScary 27 | . T.words 28 | . T.pack 29 | =<< getContents 30 | -------------------------------------------------------------------------------- /week1/scary/kirikaza/Scary.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Char (isAsciiLower, isAsciiUpper, ord) 4 | 5 | main :: IO () 6 | main = do 7 | file <- getContents 8 | let allWords = lines file 9 | let scaryWords = filter isScary allWords 10 | mapM_ putStrLn scaryWords 11 | 12 | isScary :: String -> Bool 13 | isScary word = sum (map weigh word) == 13 14 | where weigh char 15 | | isAsciiLower char = ord char - ord 'a' + 1 16 | | isAsciiUpper char = ord char - ord 'A' + 1 17 | | otherwise = 0 18 | 19 | -------------------------------------------------------------------------------- /week1/scary/kirikaza/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /week1/scary/kirikaza/scary.cabal: -------------------------------------------------------------------------------- 1 | name: scary 2 | version: 0.1.0.0 3 | synopsis: Haskell exercises: Week 1: Task 1: Find scary words (by kirikaza) 4 | homepage: https://github.com/neongreen/haskell-ex 5 | author: Kirill Kazakov 6 | maintainer: k@kirikaza.ru 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable scary 11 | hs-source-dirs: . 12 | main-is: Scary.hs 13 | default-language: Haskell2010 14 | build-depends: base >= 4.7 && < 5 15 | -------------------------------------------------------------------------------- /week1/scary/kirikaza/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.4 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /week1/scary/kirikaza/try.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | set -e 4 | cd "$(dirname "$0")" 5 | for dic in /usr/share/dict/words /usr/dict/words ; do 6 | if [ -r "$dic" ] ; then 7 | exec stack runghc Scary.hs < "$dic" 8 | fi 9 | done 10 | echo >&2 "couldn't find file with words" 11 | exit 2 12 | -------------------------------------------------------------------------------- /week1/scary/knikel/Scary.hs: -------------------------------------------------------------------------------- 1 | -- Scary.hs 2 | -- Assume "words.txt" exists alongside this file 3 | 4 | module Scary (scaryWords, isScary) where 5 | import Data.Char (ord, toLower) 6 | 7 | -- Find all *scary* words in the given list xs 8 | scaryWords :: [String] -> [String] 9 | scaryWords xs = filter isScary xs 10 | 11 | isScary :: String -> Bool 12 | isScary s = total == scaryNumber 13 | where total = sum $ map charToNumber s 14 | scaryNumber = 13 15 | 16 | charToNumber :: Char -> Int 17 | charToNumber c 18 | | elem char alphabet = (+) asciiOffset $ ord char 19 | | otherwise = 0 20 | where asciiOffset = -97 + 1 21 | alphabet = ['a'..'z'] 22 | char = toLower c 23 | 24 | main :: IO() 25 | main = do 26 | content <- readFile "words.txt" 27 | print $ scaryWords $ lines content 28 | -------------------------------------------------------------------------------- /week1/scary/knikel/ScaryTests.hs: -------------------------------------------------------------------------------- 1 | -- run with: stack runghc -- -Wall ScaryTests.hs 2 | import Test.HUnit (Assertion, (@=?), runTestTT, Test(..), Counts(..)) 3 | import Scary (scaryWords, isScary) 4 | import System.Exit (ExitCode(..), exitWith) 5 | 6 | exitProperly :: IO Counts -> IO () 7 | exitProperly m = do 8 | counts <- m 9 | exitWith $ if failures counts /= 0 || errors counts /= 0 then ExitFailure 1 else ExitSuccess 10 | 11 | testCase :: String -> Assertion -> Test 12 | testCase label assertion = TestLabel label (TestCase assertion) 13 | 14 | main :: IO () 15 | main = exitProperly $ runTestTT $ TestList 16 | [ TestList isScaryTests 17 | , TestList scaryTests 18 | ] 19 | 20 | isScaryTests :: [Test] 21 | isScaryTests = 22 | [ testCase "isScary: False on empty string" $ 23 | False @=? isScary "" 24 | , testCase "isScary can recognize a *scary* word" $ 25 | True @=? isScary "baaed" 26 | , testCase "isScary can recognize a *non-scary* word" $ 27 | False @=? isScary "notscary" 28 | , testCase "isScary can handle non-lowercase word" $ 29 | False @=? isScary "Iraq" 30 | , testCase "isScary can handle non-alphabet word" $ 31 | False @=? isScary "zip's" 32 | ] 33 | 34 | scaryTests :: [Test] 35 | scaryTests = 36 | [ testCase "No scary words in the empty list" $ 37 | [] @=? scaryWords [] 38 | , testCase "No scary words in the list" $ 39 | [] @=? scaryWords ["no", "no", "no"] 40 | , testCase "Two scary words in the list" $ 41 | [ "baaed", "baaed" ] @=? scaryWords ["no", "baaed", "baaed"] 42 | ] 43 | -------------------------------------------------------------------------------- /week1/scary/lukvol/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | 4 | scareFactor :: Char -> Int 5 | scareFactor c 6 | | isLetter c = ord (toUpper c) - ord 'A' + 1 7 | | otherwise = 0 8 | 9 | checkWord :: [Char] -> Int 10 | checkWord = sum . map scareFactor 11 | 12 | main = do 13 | dictionary <- readFile "/usr/share/dict/words" 14 | let wordsToCheck = lines dictionary 15 | let scaryWords = [x | x <- wordsToCheck, (checkWord x) == 13] 16 | print(scaryWords) -------------------------------------------------------------------------------- /week1/scary/maverickchaser/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.Char 3 | 4 | magickNumber = 13 5 | fPath = "/usr/share/dict/words" 6 | 7 | isScary :: [Char] -> Bool 8 | isScary word 9 | | isAlphaOnly word && foldl (\acc c -> acc + ord (toUpper c) - ord 'A' + 1) 0 word == magickNumber = True 10 | | otherwise = False 11 | where isAlphaOnly = all (isAlpha) 12 | 13 | main = do 14 | withFile fPath ReadMode (\handle -> do 15 | content <- hGetContents handle 16 | print $ filter isScary $ lines content) 17 | -------------------------------------------------------------------------------- /week1/scary/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | charValue :: Char -> Int 4 | charValue c 5 | | isAscii c && isLetter c = ord (toLower c) - ord 'a' + 1 6 | | otherwise = 0 7 | 8 | isScary :: String -> Bool 9 | isScary xs = sum (map charValue xs) == 13 10 | 11 | main :: IO () 12 | main = do 13 | ws <- words <$> readFile "/usr/share/dict/words" 14 | putStrLn $ unwords (filter isScary ws) 15 | -------------------------------------------------------------------------------- /week1/scary/sth-fish/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.Char 3 | 4 | abcOrd :: Char -> Int 5 | abcOrd char 6 | | isAscii char && isLetter char = ord (toLower char) - ord 'a' + 1 7 | | otherwise = 0 8 | 9 | abcOrdSum :: String -> Int 10 | abcOrdSum word = sum (map abcOrd word) 11 | 12 | isScary :: String -> Bool 13 | isScary word = abcOrdSum word == 13 14 | 15 | main = do 16 | contents <- readFile "words" 17 | let words = lines contents 18 | print(filter isScary words) 19 | -------------------------------------------------------------------------------- /week1/scary/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | 3 | isScary :: String -> Bool 4 | isScary word = 5 | let 6 | filtered :: String 7 | filtered = map toLower $ filter isAlpha word 8 | charToInt :: Char -> Int 9 | charToInt c = ord c - ord 'a' + 1 10 | in 11 | sum (map charToInt filtered) == 13 12 | 13 | main :: IO () 14 | main = do 15 | ws <- lines <$> getContents 16 | let scaryWs = filter isScary ws 17 | mapM_ putStrLn scaryWs 18 | -------------------------------------------------------------------------------- /week1/scary/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Char 4 | 5 | scaryInt = 13 6 | 7 | isGoodChar :: Char -> Bool 8 | isGoodChar c = isAscii c && isLetter c 9 | 10 | scaryCharToInt :: Char -> Int 11 | scaryCharToInt c 12 | | isGoodChar c = ord (toLower c) - 96 13 | | otherwise = 0 14 | 15 | scarySum :: String -> Int 16 | scarySum = helper 0 where 17 | helper :: Int -> String -> Int 18 | helper acc [] = acc 19 | helper acc (c:cs) 20 | | acc > scaryInt = acc 21 | | otherwise = helper (acc + scaryCharToInt c) cs 22 | 23 | 24 | isScary :: String -> Bool 25 | isScary cs = scaryInt == scarySum cs 26 | 27 | main :: IO () 28 | main = do 29 | dict <- getContents 30 | let scaryWords = filter isScary (lines dict) 31 | putStrLn $ unlines scaryWords 32 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Author name here (c) 2016 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. -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/app/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Game 4 | 5 | main :: IO () 6 | main = startGame 7 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/src/Game.hs: -------------------------------------------------------------------------------- 1 | module Game(startGame) where 2 | 3 | import Control.Monad 4 | import Data.Char 5 | import Data.List 6 | import Draw 7 | 8 | type ErrorMessage = String 9 | type TokenSymbol = Char 10 | type Cell = (Char, Int, TokenSymbol) 11 | type Board = [Cell] 12 | 13 | data Token = Token Char | X | O 14 | data Player = Player Token | Computer Token 15 | 16 | data GameError = WrongPosition | PositionIsBusy 17 | data Game = Game { 18 | currentPlayer :: Player 19 | , players :: (Player, Player) 20 | , board :: Board 21 | } 22 | | GameEnded Player 23 | 24 | -- createGame makes a new game 25 | createGame :: Player -> Game 26 | createGame (Player (Token ch)) = 27 | let 28 | makeComputer 'X' = Computer O 29 | makeComputer 'O' = Computer X 30 | 31 | player = Player (Token ch) 32 | computer = makeComputer ch 33 | board = [] 34 | 35 | in 36 | Game { 37 | currentPlayer = player 38 | , players = (player, computer) 39 | , board = board 40 | } 41 | 42 | startGame :: IO Game 43 | startGame = do 44 | choise <- promptPlayerType 45 | let 46 | game = createGame (Player (Token choise)) 47 | in 48 | return (processingGame game) 49 | 50 | processingGame :: Game -> Game 51 | processingGame (GameEnded p) = GameEnded p 52 | 53 | -- checkPosition check's can would the player put 54 | checkPosition :: BoardPosition -> Game -> (Bool, ErrorMessage) 55 | checkPosition (Position x y) game = 56 | case foundedPositions of 57 | [] -> (True, "") 58 | [x] -> (False, "Selected position was busy") 59 | where 60 | foundedPositions = filter (\(pX, pY, _) -> pX == x && pY == y) (board game) 61 | 62 | -- searchPosition is looking for a free position 63 | searchPosition :: Game -> BoardPosition 64 | searchPosition game = 65 | undefined 66 | 67 | -- go 68 | go :: Player -> Either (Game, GameError) Game 69 | go (Computer t) = Right (aiGo (Computer t)) 70 | go (Player t) = playerGo (Player t) 71 | 72 | -- aiGo does step for AI 73 | aiGo :: Player -> Game 74 | aiGo (Computer t) = undefined 75 | 76 | -- palyerGo asks player step about 77 | playerGo :: Player -> Either (Game, GameError) Game 78 | playerGo (Player t) = 79 | undefined 80 | 81 | promptPlayerType :: IO Char 82 | promptPlayerType = do 83 | putStr "\nChoise (x or o): " 84 | select <- getChar 85 | let choise = toUpper select 86 | in 87 | if choise == 'X' || choise == 'O' then 88 | return choise 89 | else 90 | promptPlayerType 91 | 92 | promptMove :: IO BoardPosition 93 | promptMove = do 94 | pos <- drawPrompt 95 | case convertStrToPosition pos of 96 | PositionUnsupported _ -> 97 | promptMove 98 | pos -> return pos 99 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/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 | # http://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-6.15 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: [ansi-terminal-0.6.2.3] 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.1" 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 67 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | -------------------------------------------------------------------------------- /week1/tictactoe/avatar29A/tictac/tictac.cabal: -------------------------------------------------------------------------------- 1 | name: tictac 2 | version: 0.1.0.0 3 | synopsis: A learning project 4 | description: Please see README.md 5 | homepage: https://github.com/avatar29A/tictac#readme 6 | license: MIT 7 | license-file: LICENSE 8 | author: Glebov Boris 9 | maintainer: avatar29A@gmail.com 10 | copyright: 2016 Glebov Boris 11 | category: Console 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Draw 19 | build-depends: base >= 4.7 && < 5 20 | , ansi-terminal 21 | default-language: Haskell2010 22 | 23 | executable tictac-exe 24 | hs-source-dirs: app 25 | main-is: Main.hs 26 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 27 | build-depends: base 28 | , tictac 29 | default-language: Haskell2010 30 | 31 | test-suite tictac-test 32 | type: exitcode-stdio-1.0 33 | hs-source-dirs: test 34 | main-is: Spec.hs 35 | build-depends: base 36 | , tictac 37 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 38 | default-language: Haskell2010 39 | 40 | source-repository head 41 | type: git 42 | location: https://github.com/avatar29A/tictac 43 | -------------------------------------------------------------------------------- /week1/tictactoe/callmecabman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Console.ANSI 4 | import Control.Monad 5 | 6 | -- terminal control functions 7 | 8 | resetSGR :: IO () 9 | resetSGR = setSGR [Reset] 10 | 11 | setColor :: Color -> IO () 12 | setColor c = setSGR [SetColor Foreground Vivid c] 13 | 14 | resetScreen :: IO () 15 | resetScreen = clearScreen >> resetSGR >> setCursorPosition 0 0 16 | 17 | -- custom game representation 18 | 19 | data Cell = Empty 20 | | X 21 | | O 22 | 23 | showCell :: Cell -> IO () 24 | showCell c = do case c of 25 | X -> setColor Green >> putStr "X" 26 | O -> setColor Red >> putStr "O" 27 | _ -> return () 28 | resetSGR 29 | 30 | type Grid = [[Cell]] 31 | 32 | emptyGrid :: Grid 33 | emptyGrid = [ [Empty, Empty, Empty] 34 | , [Empty, Empty, Empty] 35 | , [Empty, Empty, Empty] ] 36 | 37 | -- main stuff 38 | 39 | showGrid :: Grid -> IO () 40 | showGrid g = showFrame 41 | 42 | showFrame :: IO () 43 | showFrame = do resetScreen 44 | mapM_ putStrLn theFrame 45 | 46 | setCursorWithinGrid :: Int -> Int -> IO () 47 | setCursorWithinGrid r c = setCursorPosition (2*r) (2*c) 48 | 49 | setCursorOnStatus :: IO () 50 | setCursorOnStatus = setCursorPosition 9 0 51 | 52 | setCursorOnInput :: IO () 53 | setCursorOnInput = setCursorPosition 11 0 54 | 55 | mainLoop :: Grid -> IO Grid 56 | mainLoop g = do 57 | showFrame 58 | setCursorWithinGrid 1 1 59 | showCell O 60 | setCursorOnStatus 61 | putStr "Your move" 62 | setCursorOnInput 63 | colC <- getChar 64 | rowC <- getChar 65 | return g 66 | 67 | main :: IO () 68 | main = do setTitle "h3t" 69 | mainLoop emptyGrid >>= mainLoop -- and so on 70 | return () 71 | 72 | theFrame:: [String] 73 | theFrame = [ " A B C" 74 | , " ┏━┯━┯━┓" 75 | , "1┃ | | ┃" 76 | , " ┠─┼─┼─┨" 77 | , "2┃ | | ┃" 78 | , " ┠─┼─┼─┨" 79 | , "3┃ | | ┃" 80 | , " ┗━┷━┷━┛" ] 81 | -------------------------------------------------------------------------------- /week1/wilson/jonaprieto/Wilson.hs: -------------------------------------------------------------------------------- 1 | -- | Wilson's algorithm 2 | 3 | {-# LANGUAGE UnicodeSyntax #-} 4 | 5 | module Wilson 6 | where 7 | 8 | data Node = Node Int Int 9 | data Tree = EmptyTree | Leaf Node | Tree [Tree] 10 | data Edge = Edge Node Node 11 | 12 | type Source = Node 13 | type Target = Node 14 | 15 | type Positon = (Int, Int) 16 | 17 | data Step = Step { movX :: Int, movY :: Int } -- like a offset 18 | 19 | offset ∷ [Step] 20 | offset = 21 | [ Step { movX = 1, movY = 0 } --right 22 | , Step { movX = 0, movY = 1 } --up 23 | , Step { movX = -1, movY = 0 } --left 24 | , Step { movX = 1, movY = -1 } --down 25 | ] 26 | 27 | type Steps = [Step] 28 | type Table = [Node] 29 | 30 | 31 | -- Description of the Wilson's algorithm: 32 | -- 33 | -- Choose any vertex at random and add it to the UST. 34 | -- Select any vertex that is not already in the UST and perform a random walk until you encounter a vertex that is in the UST. 35 | -- Add the vertices and edges touched in the random walk to the UST. 36 | -- Repeat 2 and 3 until all vertices have been added to the UST. 37 | 38 | getMaze :: Table → Tree → Tree 39 | getMaze table ust = undefined 40 | -- node = randomNode table 41 | -- check node is not in ust 42 | -- newUST = addNode node ust 43 | -- node2 = randomNode table 44 | -- vertex that is not already in the UST 45 | -- .. 46 | 47 | 48 | addNode :: Node → Tree → Tree 49 | addNode = undefined 50 | 51 | addEdge ∷ Edge → Tree → Tree 52 | addEdge = undefined 53 | 54 | isNodeIn ∷ Node → Tree → Bool 55 | isNodeIn = undefined 56 | 57 | makeStep ∷ Node → Node 58 | makeStep = undefined 59 | 60 | randomWalk ∷ Source → Target → Steps 61 | randomWalk = undefined 62 | 63 | randomNode ∷ [Node] → Node 64 | randomNode = undefined 65 | 66 | generateTable ∷ Int → Table 67 | generateTable = undefined 68 | 69 | plotMaze ∷ Table → Tree → IO () 70 | plotMaze = undefined 71 | 72 | main ∷ IO () 73 | main = do 74 | nn ← getLine 75 | 76 | let size ∷ Int 77 | size = read nn ∷ Int 78 | 79 | let table ∷ Table 80 | table = generateTable size 81 | 82 | let maze ∷ Tree 83 | maze = getMaze table EmptyTree 84 | 85 | plotMaze table maze 86 | -------------------------------------------------------------------------------- /week1/wilson/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Foldable 2 | import Data.Array 3 | import Data.Random -- from random-fu 4 | import Data.Maybe 5 | import Lens.Micro -- from microlens 6 | 7 | 8 | type Size = (Int, Int) -- width, height 9 | type Pos = (Int, Int) -- X, Y 10 | 11 | data Arrow = U | D | L | R | Start 12 | deriving (Eq, Show) 13 | 14 | randomWalk 15 | :: Size -- ^ Size of the field 16 | -> Pos -- ^ Starting cell 17 | -> (Pos -> Bool) -- ^ When to stop 18 | -> RVar [(Pos, Arrow)] 19 | randomWalk size pos stop = go pos 20 | where 21 | mazeBounds = ((0, 0), (fst size - 1, snd size - 1)) 22 | 23 | neighbors :: Pos -> [(Pos, Arrow)] 24 | neighbors (x,y) = filter (inRange mazeBounds . fst) [ 25 | ((x,y-1), U), ((x,y+1), D), 26 | ((x-1,y), L), ((x+1,y), R) ] 27 | 28 | go :: Pos -> RVar [(Pos, Arrow)] 29 | go p = do 30 | (p', d) <- randomElement (neighbors p) 31 | if stop p' then return [(p, d)] else ((p, d):) <$> go p' 32 | 33 | -- | Simplify the walk by cutting out the cycles. If a cell is encountered 34 | -- several times in the walk, then the whole segment from the first encounter 35 | -- to the last encounter (but not including it) will be removed. 36 | -- 37 | -- 12345678 1|23456|78 178 38 | -- ABCBDDBE -> A|BCBDD|BE -> ABE 39 | simplifyWalk :: [(Pos, Arrow)] -> [(Pos, Arrow)] 40 | simplifyWalk [] = [] 41 | simplifyWalk ((pos, arrow):rest) = 42 | case break ((== pos) . fst) (simplifyWalk rest) of 43 | (xs, []) -> (pos, arrow) : xs 44 | (_, ys) -> ys 45 | 46 | wilson :: Size -> IO (Array (Int, Int) Arrow) 47 | wilson size@(width, height) = sample $ do 48 | startCell <- (,) <$> uniform 0 (width-1) <*> uniform 0 (height-1) 49 | fill (startArray startCell) 50 | where 51 | startArray :: (Int, Int) -> Array (Int, Int) (Maybe Arrow) 52 | startArray startCell = 53 | listArray ((0,0),(width-1,height-1)) (repeat Nothing) 54 | // [(startCell, Just Start)] 55 | 56 | fill :: Array (Int, Int) (Maybe Arrow) 57 | -> RVar (Array (Int, Int) Arrow) 58 | fill arr = do 59 | let empties = map fst $ filter (isNothing . snd) (assocs arr) 60 | case empties of 61 | [] -> return (fmap fromJust arr) 62 | (x:_) -> do 63 | walk <- randomWalk size x (\p -> isJust (arr ! p)) 64 | fill (arr // map (over _2 Just) (simplifyWalk walk)) 65 | 66 | printArrows :: Array (Int, Int) Arrow -> IO () 67 | printArrows arr = do 68 | let (lastX, lastY) = snd (bounds arr) 69 | for_ [0 .. lastY] $ \y -> do 70 | for_ [0 .. lastX] $ \x -> 71 | case arr ! (x, y) of 72 | U -> putChar '↑'; D -> putChar '↓' 73 | L -> putChar '←'; R -> putChar '→' 74 | Start -> putChar '•' 75 | putStrLn "" 76 | 77 | printMaze :: Array (Int, Int) Arrow -> IO () 78 | printMaze arr = do 79 | let (lastX, lastY) = snd (bounds arr) 80 | putStrLn (" " ++ replicate (2*lastX+1) '_') 81 | for_ [0 .. lastY] $ \y -> do 82 | putChar '|' 83 | for_ [0 .. lastX] $ \x -> do 84 | let noVerticalConnection = arr ! (x,y) /= D && arr ! (x,y+1) /= U 85 | noHorizontalConnection = arr ! (x,y) /= R && arr ! (x+1,y) /= L 86 | putChar $ if y == lastY || noVerticalConnection then '_' else ' ' 87 | putChar $ if x == lastX || noHorizontalConnection then '|' else ' ' 88 | putStrLn "" 89 | 90 | main :: IO () 91 | main = do 92 | putStr "Size: "; n <- readLn 93 | printMaze =<< wilson (n,n) 94 | -------------------------------------------------------------------------------- /week1/wilson/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Data.Matrix (Matrix) 5 | import qualified Data.Matrix as M 6 | import Data.Set (Set) 7 | import qualified Data.Set as S 8 | import qualified Data.Vector as V 9 | import System.Random 10 | 11 | data Direction = None | North | East | South | West 12 | deriving (Eq, Enum, Ord, Show) 13 | 14 | type Index = (Int, Int) 15 | 16 | data Maze = Maze 17 | { inside :: Set Index -- these are already in the maze 18 | , outside :: Set Index -- not yet in the maze 19 | , field :: Matrix Direction} deriving (Show) 20 | 21 | -- note that random will never return None 22 | instance Random Direction where 23 | randomR (a, b) g = (dir, g') where 24 | (x, g') = randomR (fromEnum a, fromEnum b) g 25 | dir = toEnum x 26 | random = randomR (North, West) 27 | 28 | -- all indices in a n by n matrix 29 | allIndices :: Int -> Set Index 30 | allIndices n = S.fromList [(row, col) | row <- [1..n], col <- [1..n]] 31 | 32 | getRandomIndex :: RandomGen g => g -> Set Index -> (Index, g) 33 | getRandomIndex g xs= (x, g') where 34 | (p, g') = randomR (0, S.size xs - 1) g 35 | x = S.elemAt p xs 36 | 37 | -- do not go outside the boundary 38 | isDirAllowed :: Int -> Index -> Direction -> Bool 39 | isDirAllowed dim (row, col) dir = case dir of 40 | North -> row /= 1 41 | East -> col /= dim 42 | South -> row /= dim 43 | West -> col /= 1 44 | 45 | getRandomDir :: 46 | RandomGen g => g -> Int -> Index -> (Direction, g) 47 | getRandomDir g dim x = (dir, g'') where 48 | (g', g'') = split g 49 | (dir:_) = dropWhile (not . isDirAllowed dim x) (randoms g') 50 | 51 | -- difference between current index and the neighbour in given direction 52 | dirDelta :: Direction -> (Int, Int) 53 | dirDelta dir = case dir of 54 | North -> (-1, 0) 55 | East -> (0, 1) 56 | South -> (1, 0) 57 | West -> (0, -1) 58 | 59 | step :: Direction -> Index -> Index 60 | step dir (row, col) = (row + rd, col + cd) where 61 | (rd, cd) = dirDelta dir 62 | 63 | -- walk in the current maze from 'start' cell 64 | -- which should be outside the maze 65 | -- return the first maze cell encountered 66 | -- and the maze with directions changed by the walk 67 | walk :: RandomGen g => g -> Maze -> Index -> (Index, Maze, g) 68 | walk g maze@Maze{..} start = 69 | if S.null inside || S.member start inside 70 | then (start, maze, g) 71 | else walk g' newmaze finish 72 | where 73 | (dir, g') = getRandomDir g (M.nrows field) start 74 | finish = step dir start 75 | newmaze = Maze 76 | { inside = inside 77 | , outside = outside 78 | , field = M.setElem dir start field } 79 | 80 | -- now we put into the Maze all cells in the walk 81 | -- we ignore the 'loop' cells 82 | convertWalk :: Maze -> Index -> Index -> Maze 83 | convertWalk initial@Maze{..} start finish = 84 | if start == finish then initial else convertWalk newmaze next finish 85 | where 86 | next = step (field M.! start) start 87 | newmaze = Maze 88 | { inside = S.insert start inside 89 | , outside = S.delete start outside 90 | , field = field } 91 | 92 | generateMaze :: RandomGen g => g -> Maze -> Maze 93 | generateMaze g maze@Maze{..} = 94 | if S.null outside 95 | then maze 96 | else 97 | generateMaze g'' $ convertWalk nextmaze start finish 98 | where 99 | (start, g') = getRandomIndex g outside 100 | (finish, nextmaze, g'') = walk g' maze start 101 | 102 | -- produce an 'empty' maze with only one cell inside 103 | emptyMaze :: RandomGen g => g -> Int -> (Maze, g) 104 | emptyMaze g n = (Maze{..}, g') where 105 | indices = allIndices n 106 | (first, g') = getRandomIndex g indices 107 | inside = S.fromList [first] 108 | outside = S.delete first indices 109 | field = M.fromList n n $ repeat None 110 | 111 | prettyMaze :: Maze -> String 112 | prettyMaze Maze{..} = concat 113 | [ " " 114 | , concat $ replicate n "_ " 115 | , "\n" 116 | , concat mapDS ] 117 | where 118 | n = M.nrows field 119 | mapDS = [str (row, col)| row <- [1..n], col <- [1..n]] 120 | str pos@(row, col) 121 | | col == 1 = "|" ++ walls 122 | | col == n = walls ++ "\n" 123 | | otherwise = walls 124 | where 125 | walls = bottom ++ right 126 | bottom = if field M.! pos == South 127 | || (row /= n && field M.! (row+1, col) == North) 128 | then " " 129 | else "_" 130 | right = if field M.! pos == East 131 | || (col /= n && field M.! (row, col+1) == West) 132 | then " " 133 | else "|" 134 | 135 | main :: IO () 136 | main = do 137 | g <- newStdGen 138 | let 139 | (initialMaze, g') = emptyMaze g 15 140 | maze = generateMaze g' initialMaze 141 | putStrLn $ prettyMaze maze 142 | -------------------------------------------------------------------------------- /week2/bigint/balac/BigIntSpec.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.Hspec 4 | import Test.QuickCheck 5 | import BigInt 6 | import Data.Function 7 | import Control.Monad 8 | 9 | instance Arbitrary BigInt where 10 | arbitrary = fromInteger <$> arbitrary 11 | 12 | main :: IO () 13 | main = hspec $ do 14 | describe "Conversion Identity" $ 15 | it "Satisfies conversion identity w.r.t Integers." $ property $ 16 | \num -> bigToInteger ( fromInteger num :: BigInt ) === num 17 | 18 | describe "Equality" $ 19 | it "Matches Integer equality." $ property $ 20 | \a b -> ( (==) `on` ( fromInteger::Integer->BigInt ) ) a b === ( a == b ) 21 | 22 | describe "Ordering" $ 23 | it "Matches Integer ordering." $ property $ 24 | \a b -> ( compare `on` ( fromInteger :: Integer -> BigInt ) ) a b === compare a b 25 | 26 | describe "Addition" $ do 27 | it "Matches Integer addition." $ property $ 28 | \a b -> bigToInteger ( ( (+) `on` fromInteger ) a b ) === a + b 29 | 30 | it "Is commutative." $ property $ 31 | \a b -> ( ( a + b ) :: BigInt ) === ( b + a ) 32 | 33 | describe "Sign Handling" $ do 34 | it "Matches Integer abs." $ property $ 35 | \a -> bigToInteger ( abs ( fromInteger a ) ) === abs a 36 | 37 | it "Matches Integer signum." $ property $ 38 | \a -> bigToInteger ( signum ( fromInteger a ) ) === signum a 39 | 40 | it "Matches Integer negate." $ property $ 41 | \a -> bigToInteger ( negate ( fromInteger a ) ) === negate a 42 | 43 | it "Satisfies identity x = signum(x) * abs(x)." $ property $ 44 | \a -> signum a * abs a === ( a :: BigInt ) 45 | 46 | it "Satisfies identity x = negate . negate x." $ property $ 47 | \a -> ( a :: BigInt ) === negate ( negate a ) 48 | 49 | describe "Subtraction" $ do 50 | it "Matches Integer subtraction." $ property $ 51 | \a b -> bigToInteger ( ( (-) `on` fromInteger ) a b ) === a - b 52 | 53 | it "Changes sign on commutation." $ property $ 54 | \a b -> ( ( a - b ) :: BigInt ) === negate ( b - a ) 55 | 56 | describe "Multiplication" $ do 57 | it "Matches Integer multiplication." $ property $ 58 | \a b -> bigToInteger ( ( (*) `on` fromInteger ) a b ) === a * b 59 | 60 | it "Is commutative." $ property $ 61 | \a b -> ( ( a * b ) :: BigInt ) === ( ( b * a ) :: BigInt ) -------------------------------------------------------------------------------- /week2/bigint/neongreen/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Artyom (c) 2016 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 Artyom 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. -------------------------------------------------------------------------------- /week2/bigint/neongreen/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /week2/bigint/neongreen/bigint.cabal: -------------------------------------------------------------------------------- 1 | name: bigint 2 | version: 0.1.0.0 3 | synopsis: Big integers 4 | description: Big integers 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Artyom 8 | maintainer: yom@artyom.me 9 | copyright: 2016 Artyom 10 | category: Data 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | 15 | library 16 | hs-source-dirs: src 17 | exposed-modules: BigInt 18 | build-depends: base >= 4.7 && < 5 19 | default-language: Haskell2010 20 | 21 | test-suite test 22 | type: exitcode-stdio-1.0 23 | hs-source-dirs: test 24 | main-is: Spec.hs 25 | build-depends: base 26 | , bigint 27 | , hspec 28 | , QuickCheck 29 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 30 | default-language: Haskell2010 31 | -------------------------------------------------------------------------------- /week2/bigint/neongreen/src/BigInt.hs: -------------------------------------------------------------------------------- 1 | module BigInt where 2 | 3 | 4 | import Data.List 5 | import Data.Monoid 6 | 7 | 8 | data Sign = Pos | Neg 9 | deriving (Eq, Show) 10 | 11 | -- | A representation of a natural (non-negative) number: 12 | -- 0 is @[]@, 123 is @[3,2,1]@. 13 | type Nat = [Int] 14 | 15 | data BigInt = BigInt { 16 | -- | Sign (positive or negative). 0 is considered positive. 17 | sign :: Sign, 18 | nat :: Nat } 19 | deriving (Eq, Show) 20 | 21 | instance Ord BigInt where 22 | compare a b = case (sign a, sign b) of 23 | (Pos, Pos) -> compareNat (nat a) (nat b) 24 | (Neg, Neg) -> compareNat (nat b) (nat a) 25 | (Neg, Pos) -> LT 26 | (Pos, Neg) -> GT 27 | 28 | compareNat :: Nat -> Nat -> Ordering 29 | compareNat (a:as) (b:bs) = compareNat as bs <> compare a b 30 | compareNat [] [] = EQ 31 | compareNat [] _ = LT 32 | compareNat _ [] = GT 33 | 34 | {- | 35 | Bring all digits into the (0,9) interval and remove leading zeroes. Deals both with overflow and underflow: 36 | 37 | >>> normalise [12,10,5] 38 | [2,1,6] 39 | >>> normalise [-1,9] 40 | [9,8] 41 | -} 42 | normalise :: Nat -> Nat 43 | normalise = dropWhileEnd (== 0) . go 44 | where 45 | go [] = [] 46 | go [x] 47 | | x < 0 = error "normalise: negative number" 48 | | x <= 9 = [x] 49 | | otherwise = x `mod` 10 : go [x `div` 10] 50 | go (x:y:zs) = x' : go ((y+d):zs) 51 | where (d, x') = divMod x 10 52 | 53 | zipDigits :: (Int -> Int -> Int) -> Nat -> Nat -> Nat 54 | zipDigits f [] [] = [] 55 | zipDigits f (x:xs) [] = f x 0 : zipDigits f xs [] 56 | zipDigits f [] (y:ys) = f 0 y : zipDigits f [] ys 57 | zipDigits f (x:xs) (y:ys) = f x y : zipDigits f xs ys 58 | 59 | addNat :: Nat -> Nat -> Nat 60 | addNat a b = normalise (zipDigits (+) a b) 61 | 62 | subNat :: Nat -> Nat -> Nat 63 | subNat a b = normalise (zipDigits (-) a b) 64 | 65 | mulNat :: Nat -> Nat -> Nat 66 | mulNat a b = normalise $ foldr (zipDigits (+)) [] partials 67 | where 68 | partials = [replicate i 0 ++ map (*x) b | (i, x) <- zip [0..] a] 69 | 70 | biToInteger :: BigInt -> Integer 71 | biToInteger (BigInt Pos xs) = natToInteger xs 72 | biToInteger (BigInt Neg xs) = negate (natToInteger xs) 73 | 74 | natToInteger :: Nat -> Integer 75 | natToInteger = sum . zipWith (*) (iterate (10*) 1) . map toInteger 76 | 77 | integerToNat :: Integer -> Nat 78 | integerToNat 0 = [] 79 | integerToNat n = fromInteger m : integerToNat d 80 | where (d, m) = divMod n 10 81 | 82 | instance Num BigInt where 83 | fromInteger n = BigInt { 84 | sign = if n >= 0 then Pos else Neg, 85 | nat = integerToNat (abs n) } 86 | 87 | negate (BigInt Pos []) = BigInt Pos [] 88 | negate (BigInt Pos xs) = BigInt Neg xs 89 | negate (BigInt Neg xs) = BigInt Pos xs 90 | 91 | abs bi = bi {sign = Pos} 92 | 93 | signum 0 = 0 94 | signum bi = bi {nat = [1]} 95 | 96 | (+) a b = case (sign a, sign b) of 97 | (Pos, Pos) -> BigInt {sign = Pos, nat = addNat (nat a) (nat b)} 98 | (Neg, Neg) -> BigInt {sign = Neg, nat = addNat (nat a) (nat b)} 99 | (Pos, Neg) 100 | | a >= (-b) -> BigInt {sign = Pos, nat = subNat (nat a) (nat b)} 101 | | otherwise -> BigInt {sign = Neg, nat = subNat (nat b) (nat a)} 102 | (Neg, Pos) -> b + a -- just use the (Pos, Neg) case 103 | 104 | (*) a b = BigInt { 105 | sign = if a == 0 || b == 0 || sign a == sign b then Pos else Neg, 106 | nat = mulNat (nat a) (nat b) } 107 | -------------------------------------------------------------------------------- /week2/bigint/neongreen/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 | # http://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-6.16 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.1" 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 -------------------------------------------------------------------------------- /week2/bigint/neongreen/test/BigIntSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | module BigIntSpec (main, spec) where 4 | 5 | import Test.Hspec 6 | import Test.QuickCheck 7 | 8 | import BigInt 9 | 10 | main :: IO () 11 | main = hspec spec 12 | 13 | arbitraryPositive :: Gen Nat 14 | arbitraryPositive = do 15 | digits <- listOf (choose (0,9)) 16 | final <- choose (1,9) 17 | return (digits ++ [final]) 18 | 19 | instance Arbitrary BigInt where 20 | arbitrary = oneof 21 | [pure (BigInt Pos []), 22 | BigInt <$> elements [Pos, Neg] <*> arbitraryPositive] 23 | 24 | spec :: Spec 25 | spec = do 26 | describe "big integer test" $ do 27 | it "3^200 + 2^300" $ 28 | biToInteger (3^200 + 2^300) `shouldBe` 3^200 + 2^300 29 | it "300!" $ 30 | biToInteger (product (map fromInteger [1..300])) `shouldBe` 31 | product [1..300] 32 | 33 | describe "properties" $ do 34 | it "fromInteger . toInteger == id" $ 35 | property $ \x -> fromInteger (biToInteger x) === x 36 | it "toInteger . fromInteger == id" $ 37 | property $ \x -> biToInteger (fromInteger x) === x 38 | it "negate . negate == id" $ 39 | property $ \(x :: BigInt) -> negate (negate x) === x 40 | it "x-x == 0" $ 41 | property $ \(x :: BigInt) -> x-x === 0 42 | it "x+x == x*2" $ 43 | property $ \(x :: BigInt) -> x+x === x*2 44 | describe "commutativity" $ do 45 | it "x+y == y+x" $ 46 | property $ \(x :: BigInt) y -> x+y === y+x 47 | it "x*y == y*x" $ 48 | property $ \(x :: BigInt) y -> x*y === y*x 49 | describe "associativity" $ do 50 | it "x+(y+z) == (x+y)+z" $ 51 | property $ \(x :: BigInt) y z -> (x+y)+z === x+(y+z) 52 | it "x*(y*z) == (x*y)*z" $ 53 | property $ \(x :: BigInt) y z -> (x*y)*z === x*(y*z) 54 | describe "identity element" $ do 55 | it "x+0 == 0+x == x" $ 56 | property $ \(x :: BigInt) -> x+0 === x .&&. 0+x === x 57 | it "x*1 == 1*x == x" $ 58 | property $ \(x :: BigInt) -> x*1 === x .&&. 1*x === x 59 | 60 | describe "testing against Integer" $ do 61 | it "Eq" $ property $ \x y -> (==) x y === liftBI2 (==) x y 62 | it "Ord" $ property $ \x y -> compare x y === liftBI2 compare x y 63 | describe "Num" $ do 64 | it "negate" $ property $ \x -> negate x === viaBI negate x 65 | it "abs" $ property $ \x -> abs x === viaBI abs x 66 | it "signum" $ property $ \x -> signum x === viaBI signum x 67 | it "(+)" $ property $ \x y -> (+) x y === viaBI2 (+) x y 68 | it "(-)" $ property $ \x y -> (-) x y === viaBI2 (-) x y 69 | it "(*)" $ property $ \x y -> (*) x y === viaBI2 (*) x y 70 | 71 | liftBI :: (BigInt -> a) -> Integer -> a 72 | liftBI f x = f (fromInteger x) 73 | 74 | liftBI2 :: (BigInt -> BigInt -> a) -> Integer -> Integer -> a 75 | liftBI2 f x y = f (fromInteger x) (fromInteger y) 76 | 77 | viaBI :: (BigInt -> BigInt) -> Integer -> Integer 78 | viaBI f x = biToInteger $ liftBI f x 79 | 80 | viaBI2 :: (BigInt -> BigInt -> BigInt) -> Integer -> Integer -> Integer 81 | viaBI2 f x y = biToInteger $ liftBI2 f x y 82 | -------------------------------------------------------------------------------- /week2/bigint/neongreen/test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /week2/compress/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Ord 2 | import Data.Maybe 3 | import Data.Function 4 | import Data.Monoid 5 | import Data.List 6 | import qualified Data.List.Safe as Safe (maximumBy) -- from safelist 7 | import Test.QuickCheck 8 | 9 | type Patch = (Int, Int) 10 | type Code = Either String Patch 11 | 12 | match :: String -> String -> Maybe Patch 13 | match back front = Safe.maximumBy (comparing snd <> comparing (Down . fst)) matches 14 | where 15 | matches = filter long $ map (`createPatch` front) (suffixes back) 16 | long xs = snd xs > 2 17 | 18 | createPatch :: (Int, String) -> String -> Patch 19 | createPatch (i, xs) ys = (i, length common) 20 | where common = takeWhile (uncurry (==)) $ zip xs ys 21 | 22 | suffixes :: String -> [(Int, String)] 23 | suffixes = zip [0..] . tails 24 | 25 | compress :: String -> [Code] 26 | compress = flatten . go [] 27 | where 28 | go :: String -> String -> [Code] 29 | go _ [] = [] 30 | go back front@(x:xs) 31 | | isNothing patch = Left [x] : go (back ++ [x]) xs 32 | | otherwise = Right (fromJust patch) : go (back ++ compressed) (drop l front) 33 | where 34 | patch = match back front 35 | (_, l) = fromJust patch 36 | compressed = take l front 37 | 38 | flatten :: [Code] -> [Code] 39 | flatten [] = [] 40 | flatten (Left x:Left y:zs) = flatten $ Left (x++y) : zs 41 | flatten (x:xs) = x : flatten xs 42 | 43 | uncompress :: [Code] -> String 44 | uncompress = go [] 45 | where 46 | go :: String -> [Code] -> String 47 | go xs [] = xs 48 | go xs (Left y:ys) = go (xs ++ y) ys 49 | go xs (Right (i, l):ys) = go (xs ++ link) ys 50 | where link = take l $ drop i xs 51 | 52 | propCompression :: String -> Property 53 | propCompression xs = (uncompress . compress) xs === xs 54 | 55 | main :: IO () 56 | main = quickCheck propCompression 57 | -------------------------------------------------------------------------------- /week2/compress/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Test.QuickCheck 3 | import Debug.Trace 4 | 5 | kMinMatch = 3 6 | 7 | commonPrefixLength :: Eq a => [a] -> [a] -> Int 8 | commonPrefixLength xs ys = length $ takeWhile ( uncurry (==) ) $ zip xs ys 9 | 10 | type Match = (Int,Int) 11 | 12 | findMatches :: String -> String -> Int -> [ Match ] 13 | findMatches [] _ _ = [] 14 | findMatches str1 str2 startOffset = 15 | if cpLength < kMinMatch 16 | then rest 17 | else ( startOffset, cpLength ) : rest 18 | where 19 | rest = findMatches ( tail str1 ) str2 ( startOffset + 1 ) 20 | cpLength = commonPrefixLength str1 str2 21 | 22 | biggestMatch :: String -> String -> Maybe Match 23 | biggestMatch str1 str2 = case findMatches str1 str2 0 of 24 | [] -> Nothing 25 | xs -> Just ( ( head . reverse ) $ sortOn snd xs ) 26 | 27 | matchSuffixes :: [String] -> [ (Int,String) ] -> [ (Int, Match) ] 28 | matchSuffixes (prefix:prefixes) ((soffset,suffix):suffixes) = 29 | case biggestMatch prefix suffix of 30 | Nothing -> matchSuffixes prefixes suffixes 31 | Just match@( moffset, prefixLength ) -> (soffset, match) : matchSuffixes ( drop ( prefixLength - 1 ) prefixes ) ( drop ( prefixLength - 1 ) suffixes ) 32 | matchSuffixes _ _ = [] 33 | 34 | type Token = Either String Match 35 | 36 | toTokens :: String -> Int -> [(Int,Match)] -> [Token] 37 | toTokens [] _ _ = [] 38 | toTokens str pos [] = case drop pos str of 39 | "" -> [] 40 | rest -> [ Left rest ] 41 | toTokens str pos ((offset,m@(_,prefixLength)):matches) = 42 | if textLen > 0 43 | then Left ( take textLen $ drop pos str ) : tokens 44 | else tokens 45 | where 46 | textLen= offset - pos 47 | tokens = Right m : toTokens str ( offset + prefixLength ) matches 48 | 49 | compress :: String -> [Token] 50 | compress "" = [] 51 | compress str = toTokens str 0 matches 52 | where 53 | prefixes = tail $ inits str 54 | suffixes = tail $ zip [0..] ( tails str ) 55 | matches = matchSuffixes prefixes suffixes 56 | 57 | decompress :: [Token] -> String 58 | decompress = decompress' "" 59 | 60 | decompress' :: String -> [Token] -> String 61 | decompress' str [] = str 62 | decompress' str ( Left x : tokens ) = decompress' ( str ++ x ) tokens 63 | decompress' str ( Right (mpos,mlen) : tokens ) = decompress' ( str ++ take mlen ( drop mpos str ) ) tokens 64 | 65 | 66 | prop_inverse :: String -> Bool 67 | prop_inverse str = decompress ( compress str ) == str 68 | 69 | sampleOut1, sampleOut2, sampleOut3 :: [ Either String (Int,Int) ] 70 | 71 | sampleInp1 = "Consider a string. No, consider a different string. Whatever." 72 | sampleOut1 = [ Left "Consider a string. No, c", Right (1,10), Left "different", Right (10,9), Left "Whatever." ] 73 | sampleInp2 = "foo|bar|foobar" 74 | sampleOut2 = [Left "foo|bar|",Right (0,3),Right (4,3)] 75 | sampleInp3 = "foo|foox:foox" 76 | sampleOut3 = [Left "foo|",Right (0,3),Left "x:",Right (4,4)] 77 | 78 | 79 | main :: IO () 80 | main = do 81 | quickCheck $ compress sampleInp1 == sampleOut1 82 | quickCheck $ compress sampleInp2 == sampleOut2 83 | quickCheck $ compress sampleInp3 == sampleOut3 84 | quickCheck prop_inverse 85 | 86 | --TODO: Rewrite using State. -------------------------------------------------------------------------------- /week2/compress/jasonkuhrt/compress.cabal: -------------------------------------------------------------------------------- 1 | name: compress 2 | version: 0.1.0.0 3 | build-type: Simple 4 | -- extra-source-files: 5 | cabal-version: >=1.10 6 | 7 | library 8 | hs-source-dirs: source 9 | exposed-modules: Compress 10 | build-depends: base >= 4.7 && < 5 11 | default-language: Haskell2010 12 | 13 | test-suite compress-test 14 | type: exitcode-stdio-1.0 15 | hs-source-dirs: test 16 | main-is: Main.hs 17 | build-depends: base 18 | , hspec 19 | , QuickCheck 20 | , compress 21 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 22 | default-language: Haskell2010 23 | 24 | source-repository head 25 | type: git 26 | location: https://github.com/jasonkuhrt/compress 27 | -------------------------------------------------------------------------------- /week2/compress/jasonkuhrt/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 | # http://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-6.16 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.1" 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 -------------------------------------------------------------------------------- /week2/compress/jasonkuhrt/test/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | module Main where 3 | 4 | import Test.Hspec 5 | import qualified Compress 6 | import qualified Test.QuickCheck as QC 7 | 8 | 9 | 10 | main :: IO () 11 | main = hspec $ do 12 | 13 | describe "Compress" $ do 14 | 15 | it "(remove . put) is identity" $ do 16 | QC.property $ \string -> 17 | let 18 | f = Compress.remove . Compress.put 19 | in 20 | shouldBe (f string) string 21 | 22 | 23 | 24 | describe "Compress.put" $ do 25 | 26 | it "given empty string returns []" $ do 27 | shouldBe (Compress.put "") [] 28 | 29 | it "given string ending in non-matching 1-2 Chars ends in Left" $ do 30 | let g = QC.oneof [QC.vector 1, QC.vector 2] in 31 | QC.forAll g $ \string -> 32 | let l = last (Compress.put ("Hello world.Hello world." ++ string)) 33 | in shouldBe l (Left string) 34 | 35 | it "given string divisable by 3 does not end in empty string" $ 36 | let string = "123456789" 37 | in shouldBe (Compress.put string) [Left string] 38 | 39 | it "compresses foo|foox:foox" $ 40 | shouldBe 41 | (Compress.put "foofooxfoox") 42 | [Left "foo", Right (0,3), Left "x", Right (3,4)] 43 | -- (Compress.put "foo|foox:foox") 44 | -- [Left "foo|", Right (0,3), Left "x:", Right (5,4), Left "x"] 45 | -------------------------------------------------------------------------------- /week2/compress/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Ord 2 | import Data.List 3 | import Data.Either 4 | import Test.QuickCheck 5 | 6 | main = do 7 | let prop = \xs -> decompress (compress xs) === xs 8 | quickCheck prop 9 | quickCheck $ forAllShrink genStr shrink prop 10 | 11 | genStr :: Gen String 12 | genStr = concat <$> listOf (oneof [part, arbitrary]) 13 | where 14 | part = growingElements ["a","bc","def","ghij","klmno","pqrstu"] 15 | 16 | type Token = Either String (Int, Int) -- Starting position, length 17 | 18 | {- | 19 | >>> prefixLength "hello" "world" 20 | 0 21 | >>> prefixLength "hello" "hex" 22 | 2 23 | -} 24 | prefixLength :: String -> String -> Int 25 | prefixLength p s = length (takeWhile id (zipWith (==) p s)) 26 | 27 | {- | 28 | Find longest match of two strings. For instance, @longestMatch "abacaba" "bac"@ will find two matches: 29 | 30 | @ 31 | 1. a|bac|aba 2. abaca|ba| 32 | |bac| |ba|c 33 | @ 34 | 35 | and choose the first one, because it's longer. The resulting match will be @(1,3)@ – starts from index 1, length = 3. If there's no match, length will be 0. 36 | -} 37 | longestMatch :: String -> String -> (Int, Int) 38 | longestMatch p s = maximumBy (comparing snd) matches 39 | where 40 | matches :: [(Int, Int)] 41 | matches = [(i, prefixLength p' s) | (i, p') <- zip [0..] (tails p)] 42 | 43 | {- | 44 | Consolidate all characters found by 'compress' into strings. 45 | 46 | >>> consolidate [Left "x", Left "y", Right (0,3)] 47 | [Left "xy", Right (0,3)] 48 | -} 49 | consolidate :: [Token] -> [Token] 50 | consolidate [] = [] 51 | consolidate (Right x : xs) = Right x : consolidate xs 52 | consolidate xs = Left (concat (lefts ls)) : consolidate rest 53 | where (ls, rest) = span isLeft xs 54 | 55 | compress :: String -> [Token] 56 | compress s = consolidate $ go "" s 57 | where 58 | -- Do the compression. The first parameter is the string we've already 59 | -- processed, the second – string left to process. 60 | go :: String -> String -> [Token] 61 | go _ "" = [] 62 | go p (c:cs) 63 | -- We have the index (i) and the length (n) of the longest 64 | -- match. However, if the match is too short, we instead yield a single 65 | -- character (c) as a string token and continue. 66 | | n < 3 = Left [c] : go (p ++ [c]) cs 67 | -- If the match isn't too short, we cut it out of 's', yield it, and 68 | -- continue with the rest of 's'. 69 | | otherwise = let (match, rest) = splitAt n (c:cs) 70 | in Right (i,n) : go (p ++ match) rest 71 | where 72 | (i,n) = longestMatch p (c:cs) 73 | 74 | decompress :: [Token] -> String 75 | decompress xs = uncompressed 76 | where 77 | uncompressed = concatMap deRef xs 78 | deRef (Left x) = x 79 | deRef (Right (i,n)) = take n (drop i uncompressed) 80 | 81 | {- A slower version without tying the knot: 82 | 83 | decompress :: [Token] -> String 84 | decompress s = go [] s 85 | where 86 | go p [] = p 87 | go p (Left x : xs) = go (p ++ x) xs 88 | go p (Right (i,n) : xs) = go (p ++ take n (drop i p)) xs 89 | -} 90 | -------------------------------------------------------------------------------- /week2/compress/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | import Data.Vector (Vector) 5 | import qualified Data.Vector as V 6 | import Test.QuickCheck 7 | 8 | -- | Start position, Length 9 | type Interval = (Int, Int) 10 | -- | Similar to above: Start position, Piece of sequence. 11 | -- | We need to keep track of position within original sequence. 12 | type Sub a = (Int, Vector a) 13 | type Compressed a = Either (Sub a) Interval 14 | 15 | vCompressWith :: Eq a => Sub a -> Sub a -> [Compressed a] 16 | vCompressWith (sp, s) (vp, v) 17 | | ls == 0 || lv == 0 || ls > lv = [Left (vp, v)] 18 | | otherwise = replace 0 repeats 19 | where 20 | ls = V.length s 21 | lv = V.length v 22 | -- | Indices where first letter of subseq is found in seq - 23 | -- | just a small kick of performance. 24 | is = V.toList $ V.elemIndices (V.head s) (V.slice 0 (lv-ls+1) v) 25 | -- | Among those above, pick the ones that are the start 26 | -- | of actual subseq in the seq; drop the first occurance. 27 | -- | Note: we need to keep track of current pos in the seq (vpos), 28 | -- | to avoid overlapping subseqs, e.g. "aa" in "aaa". 29 | repeats = reverse $ fst $ foldl' f ([], 0) is 30 | f (finds, vpos) spos 31 | | spos < vpos || spos + ls > lv = (finds, vpos) 32 | | vp + spos < sp && vp + spos + ls > sp = (finds, spos) 33 | | sp == vp + spos = (finds, spos + ls) 34 | | otherwise = if s == V.slice spos ls v 35 | then (spos:finds, spos + ls) 36 | else (finds, spos) 37 | -- | Replace the repeating subseqs with Right (start, length), 38 | -- | The leftovers will be turned into Left Sub a. 39 | replace pos (next:rest) = 40 | let 41 | prefix = V.slice pos (next - pos) v 42 | replacement = Right (sp, ls) : replace (next + ls) rest 43 | in 44 | if V.null prefix 45 | then replacement 46 | else Left (vp+pos, prefix) : replacement 47 | replace pos [] 48 | | pos < lv = [Left (vp+pos, V.slice pos (lv-pos) v)] 49 | | otherwise = [] 50 | 51 | -- | Same idea as vCompressWith, but here we look for subseq among 52 | -- | the Left in [Compressed a] 53 | compressWith :: (Eq a) => Sub a -> [Compressed a] -> [Compressed a] 54 | compressWith (sp, s) = concatMap f 55 | where 56 | f (Right sub)= [Right sub] 57 | f (Left (vp, v)) = cv where 58 | cv = vCompressWith (sp, s) (vp, v) 59 | 60 | slice :: Int -> Int -> [Compressed a] -> Vector a 61 | slice p n c = case c of 62 | [] -> V.empty 63 | (Right _ : cs) -> slice p n cs 64 | (Left (pos, v) : cs) -> 65 | if p >= pos && p+n <= pos + V.length v 66 | then V.slice (p-pos) n v 67 | else slice p n cs 68 | 69 | 70 | minSubLength = 3 71 | 72 | compress :: String -> [Either String (Int, Int)] 73 | compress str = result where 74 | v = V.fromList str 75 | lv = V.length v 76 | 77 | result = map remap $ loop (div lv 2) 0 [Left (0, v)] 78 | 79 | remap (Left (_, sub)) = Left $ V.toList sub 80 | remap (Right smth) = Right smth 81 | 82 | loop n p cmpd 83 | | n < minSubLength = cmpd 84 | | p > lv - n = loop (n-1) 0 cmpd 85 | | otherwise = loop n (p+1) further 86 | where 87 | sub = slice p n cmpd 88 | further = if V.null sub then cmpd else compressWith (p, sub) cmpd 89 | 90 | 91 | decompress :: [Either String (Int, Int)] -> String 92 | decompress c = V.toList $ foldl' f V.empty c where 93 | f acc (Left s) = acc V.++ V.fromList s 94 | f acc (Right (i, n)) = acc V.++ V.slice i n acc 95 | 96 | 97 | prop_compdecomp :: String -> Bool 98 | prop_compdecomp s = s == (decompress . compress) s 99 | 100 | main :: IO () 101 | main = quickCheck prop_compdecomp 102 | -------------------------------------------------------------------------------- /week2/jpath/balac/store.js: -------------------------------------------------------------------------------- 1 | { "store": { 2 | "book": [ 3 | { "category": "reference", 4 | "author": "Nigel Rees", 5 | "title": "Sayings of the Century", 6 | "price": 8.95 7 | }, 8 | { "category": "fiction", 9 | "author": "Evelyn Waugh", 10 | "title": "Sword of Honour", 11 | "price": 12.99 12 | }, 13 | { "category": "fiction", 14 | "author": "Herman Melville", 15 | "title": "Moby Dick", 16 | "isbn": "0-553-21311-3", 17 | "price": 8.99 18 | }, 19 | { "category": "fiction", 20 | "author": "J. R. R. Tolkien", 21 | "title": "The Lord of the Rings", 22 | "isbn": "0-395-19395-8", 23 | "price": 22.99 24 | } 25 | ], 26 | "bicycle": { 27 | "color": "red", 28 | "price": 19.95 29 | } 30 | } 31 | } -------------------------------------------------------------------------------- /week2/jpath/neongreen/jp.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | 4 | -- General 5 | import Data.Functor 6 | import Data.Maybe 7 | -- Text 8 | import qualified Data.Text as T 9 | import Data.Text (Text) 10 | -- ByteString 11 | import qualified Data.ByteString.Lazy.Char8 as BSL 12 | -- JSON 13 | import Data.Aeson -- from aeson 14 | import Data.Aeson.Encode.Pretty -- from aeson-pretty 15 | import qualified Data.HashMap.Strict as HM -- from unordered-containers 16 | import qualified Data.Vector as V -- from vector 17 | -- Parsing 18 | import Text.Megaparsec -- from megaparsec 19 | import Text.Megaparsec.Text 20 | import Text.Megaparsec.Lexer (integer) 21 | -- CLI stuff 22 | import System.Environment (getArgs, getProgName) 23 | import System.Exit (die) 24 | 25 | 26 | ---------------------------------------------------------------------------- 27 | -- Types 28 | ---------------------------------------------------------------------------- 29 | 30 | type Path = [Selector] 31 | 32 | data Selector 33 | = Root -- '$' 34 | | Field Text -- '.foo' 35 | | Index Int -- '[3]' 36 | 37 | ---------------------------------------------------------------------------- 38 | -- Parsing 39 | ---------------------------------------------------------------------------- 40 | 41 | pathP :: Parser Path 42 | pathP = many selectorP 43 | 44 | selectorP :: Parser Selector 45 | selectorP = choice [ 46 | string "$" $> Root, 47 | optional (char '.') *> (Field <$> fieldNameP), 48 | between (char '[') (char ']') (Index <$> indexP) ] 49 | 50 | fieldNameP :: Parser Text 51 | fieldNameP = label "field name" $ 52 | T.pack <$> some (char '-' <|> char '_' <|> alphaNumChar) 53 | 54 | indexP :: Parser Int 55 | indexP = label "index" $ 56 | fromInteger <$> integer 57 | 58 | ---------------------------------------------------------------------------- 59 | -- Selecting 60 | ---------------------------------------------------------------------------- 61 | 62 | select 63 | :: Selector -- ^ Selector 64 | -> Value -- ^ Root value (used if the selector is 'Root') 65 | -> Value -- ^ Value to choose from 66 | -> [Value] 67 | select Root root val = [root] 68 | select (Field k) root (Object obj) = maybeToList (HM.lookup k obj) 69 | select (Index i) root (Array arr) = maybeToList (arr V.!? i) 70 | select _ _ _ = [] 71 | 72 | selectPath :: Path -> Value -> Value -> [Value] 73 | selectPath [] _ val = [val] 74 | selectPath (x:xs) root val = 75 | concatMap (selectPath xs root) (select x root val) 76 | 77 | ---------------------------------------------------------------------------- 78 | -- CLI, reading files, etc 79 | ---------------------------------------------------------------------------- 80 | 81 | printHelp :: IO () 82 | printHelp = do 83 | progName <- getProgName 84 | die $ unlines [ 85 | "Usage: " ++ progName ++ " QUERY FILE", 86 | "", 87 | "Example: " ++ progName ++ " \"store.book[0]\" store.js" ] 88 | 89 | processFile :: Text -> FilePath -> IO () 90 | processFile query file = do 91 | -- Parse the query as a path 92 | path <- case parse (pathP <* eof) "" query of 93 | Left err -> die $ "Error when parsing query: " ++ parseErrorPretty err 94 | Right path -> return path 95 | -- Parse JSON 96 | mbJson <- eitherDecode <$> BSL.readFile file 97 | json <- case mbJson of 98 | Left err -> die $ "Error when parsing JSON: " ++ err 99 | Right json -> return json 100 | -- Extract and print the results 101 | let results = selectPath path json json 102 | BSL.putStrLn $ encodePretty (Array (V.fromList results)) 103 | 104 | main :: IO () 105 | main = do 106 | args <- getArgs 107 | case args of 108 | [query, file] -> processFile (T.pack query) file 109 | _ -> printHelp 110 | -------------------------------------------------------------------------------- /week2/jpath/neongreen/store.js: -------------------------------------------------------------------------------- 1 | { "store": { 2 | "book": [ 3 | { "category": "reference", 4 | "author": "Nigel Rees", 5 | "title": "Sayings of the Century", 6 | "price": 8.95 7 | }, 8 | { "category": "fiction", 9 | "author": "Evelyn Waugh", 10 | "title": "Sword of Honour", 11 | "price": 12.99 12 | }, 13 | { "category": "fiction", 14 | "author": "Herman Melville", 15 | "title": "Moby Dick", 16 | "isbn": "0-553-21311-3", 17 | "price": 8.99 18 | }, 19 | { "category": "fiction", 20 | "author": "J. R. R. Tolkien", 21 | "title": "The Lord of the Rings", 22 | "isbn": "0-395-19395-8", 23 | "price": 22.99 24 | } 25 | ], 26 | "bicycle": { 27 | "color": "red", 28 | "price": 19.95 29 | } 30 | } 31 | } 32 | -------------------------------------------------------------------------------- /week2/mergesort/444c43/Main.hs: -------------------------------------------------------------------------------- 1 | mergesort :: Ord a => [a] -> [a] 2 | mergesort [] = [] 3 | mergesort [x] = [x] 4 | mergesort all@(x:xs) = 5 | let (left, right) = splitlist all 6 | in merge (mergesort left) (mergesort right) 7 | 8 | merge :: Ord a => [a] -> [a] -> [a] 9 | merge xs [] = xs 10 | merge [] ys = ys 11 | merge left@(x:xs) right@(y:ys) 12 | | x <= y = x : merge xs right 13 | | y <= x = y : merge left ys 14 | 15 | splitlist :: [a] -> ([a], [a]) 16 | splitlist list = splitAt ((length list + 1) `div` 2) list 17 | -------------------------------------------------------------------------------- /week2/mergesort/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | 3 | mergeSort :: (Ord a) => [a] -> [a] 4 | mergeSort [] = [] 5 | mergeSort [x] = [x] 6 | mergeSort xs = merge (mergeSort left) (mergeSort right) 7 | where (left, right) = divide xs 8 | 9 | merge :: (Ord a) => [a] -> [a] -> [a] 10 | merge [] b = b 11 | merge a [] = a 12 | merge a@(x:xs) b@(y:ys) 13 | | x <= y = x : merge xs b 14 | | otherwise = y : merge a ys 15 | 16 | divide :: [a] -> ([a],[a]) 17 | divide = go [] [] 18 | where go as bs [] = (as, bs) 19 | go as bs (x:xs) = go bs (x:as) xs 20 | -------------------------------------------------------------------------------- /week2/mergesort/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Data.Char 3 | 4 | mergeSort :: Ord a => [a] -> [a] 5 | mergeSort [] = [] 6 | mergeSort [x] = [x] 7 | mergeSort lst = merge ( mergeSort left ) ( mergeSort right ) 8 | where 9 | ( left, right ) = splitAt ( length lst `div` 2 ) lst 10 | merge [] xs = xs 11 | merge xs [] = xs 12 | merge first@(x:xs) second@(y:ys) = if x < y 13 | then x : merge xs second 14 | else y : merge first ys 15 | 16 | 17 | pangram = filter ( /= ' ' ) $ map toLower "The quick brown fox jumps over the lazy dog" 18 | 19 | main = do 20 | print pangram 21 | print ( mergeSort pangram ) 22 | print $ nub ( mergeSort pangram ) == ['a'..'z'] -------------------------------------------------------------------------------- /week2/mergesort/callmecabman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Bifunctor 4 | 5 | split :: [a] -> ([a], [a]) 6 | split = split' [] [] 7 | where 8 | split' xs ys [] = (xs, ys) 9 | split' xs ys (z:zs) = split' ys (z:xs) zs 10 | 11 | merge :: Ord a => ([a], [a]) -> [a] 12 | merge ([], ys) = ys 13 | merge (xs, []) = xs 14 | merge (s@(x:xs), t@(y:ys)) 15 | | x <= y = x : merge (xs, t) 16 | | otherwise = y : merge (s, ys) 17 | 18 | mergeSort :: Ord a => [a] -> [a] 19 | mergeSort [] = [] 20 | mergeSort [x] = [x] 21 | mergeSort xs = merge $ bimap mergeSort mergeSort $ split xs 22 | 23 | main :: IO () 24 | main = return () 25 | -------------------------------------------------------------------------------- /week2/mergesort/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | -- # Mergesort 3 | 4 | -- Implement a mergesort 5 | -- Invented by John von Neumann in 1945 6 | -- Reference: https://en.wikipedia.org/wiki/Merge_sort 7 | 8 | 9 | 10 | module Main where 11 | 12 | -- ## Demo 13 | 14 | main :: IO () 15 | main = do 16 | print unsortedNumbers 17 | putStr "==> MERGESORT ==>\n" 18 | print (mergesort unsortedNumbers) where 19 | unsortedNumbers :: [Int] 20 | unsortedNumbers = [1,12,5,6,21,2,61,126,7,87,23,1,451,16,46,35] 21 | 22 | 23 | 24 | -- ## Program 25 | 26 | mergesort :: Ord a => [a] -> [a] 27 | mergesort [] = [] 28 | mergesort [x] = [x] 29 | mergesort xs = go (mergesort xsLeft) (mergesort xsRight) where 30 | (xsLeft, xsRight) = halveList xs 31 | 32 | -- Do the actual sort-then-merge 33 | 34 | go :: Ord a => [a] -> [a] -> [a] 35 | go xs [] = xs 36 | go [] zs = zs 37 | go xxs@(x:xs) zzs@(z:zs) 38 | | x > z = zFirst 39 | | x < z = xFirst 40 | | otherwise = xFirst -- Preserve order AKA "stable sort" 41 | where 42 | zFirst = z : go xxs zs 43 | xFirst = x : go xs zzs 44 | 45 | 46 | 47 | -- ## Helpers 48 | 49 | halveList :: [a] -> ([a],[a]) 50 | halveList xs = splitAt (div (length xs) 2) xs 51 | -------------------------------------------------------------------------------- /week2/mergesort/neongreen/Merge.hs: -------------------------------------------------------------------------------- 1 | mergesort :: Ord a => [a] -> [a] 2 | mergesort [] = [] 3 | mergesort [x] = [x] 4 | mergesort xs = merge (mergesort a) (mergesort b) 5 | where (a, b) = divide xs 6 | 7 | merge :: Ord a => [a] -> [a] -> [a] 8 | merge [] ys = ys 9 | merge xs [] = xs 10 | merge (x:xs) (y:ys) 11 | | x <= y = x : merge xs (y:ys) 12 | | otherwise = y : merge (x:xs) ys 13 | 14 | divide :: [a] -> ([a], [a]) 15 | divide = go [] [] 16 | where 17 | go as bs [] = (as, bs) 18 | go as bs (x:xs) = go bs (x:as) xs 19 | -------------------------------------------------------------------------------- /week2/mergesort/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad 2 | 3 | merge :: (Ord a) => [a] -> [a] -> [a] 4 | merge [] [] = [] 5 | merge [] lstB = lstB 6 | merge lstA [] = lstA 7 | merge lstA@(a:as) lstB@(b:bs) = if a <= b then a : merge as lstB 8 | else b : merge lstA bs 9 | 10 | split :: (Ord a) => [a] -> ([a], [a]) 11 | split lst = splitAt (length lst `div` 2) lst 12 | 13 | mergesort :: (Ord a) => [a] -> [a] 14 | mergesort [] = [] 15 | mergesort [x] = [x] 16 | mergesort lst = 17 | merge (mergesort lstA) (mergesort lstB) 18 | where 19 | (lstA, lstB) = split lst 20 | 21 | main :: IO () 22 | main = do 23 | xs <- map (read :: String -> Int) . words <$> getContents 24 | -- print xs 25 | mapM_ print (mergesort xs) 26 | -------------------------------------------------------------------------------- /week2/mergesort/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import System.Random 4 | 5 | mergesort :: Ord a => [a] -> [a] 6 | mergesort [] = [] 7 | mergesort [x] = [x] 8 | mergesort zs = merge xs ys where 9 | h = div (length zs) 2 10 | xs = mergesort $ take h zs 11 | ys = mergesort $ drop h zs 12 | merge [] bs = bs 13 | merge as [] = as 14 | merge ls@(a:as) hs@(b:bs) = if a <= b then a:merge as hs else b:merge ls bs 15 | 16 | main :: IO () 17 | main = do 18 | g <- newStdGen 19 | let xs = take 10 $ randomRs (0::Int, 20) g 20 | print xs 21 | putStrLn "Now mergesorted:" 22 | print $ mergesort xs 23 | -------------------------------------------------------------------------------- /week2/shuffle/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import Data.Array 2 | import Control.Monad 3 | import Control.Monad.Random 4 | import Graphics.Gnuplot.Simple 5 | import Data.Function 6 | import qualified Data.HashMap.Strict as Map 7 | 8 | type MArray = Array Int Int 9 | 10 | createArray :: Int -> MArray 11 | createArray n = array (0, n-1) [ (i,i) | i <- [0..n-1] ] 12 | 13 | arrayLength :: MArray -> Int 14 | arrayLength = (+1) . snd . bounds 15 | 16 | randomPermute :: (RandomGen g) => MArray -> Int -> Rand g [(Int,Int)] 17 | randomPermute arr pos 18 | | pos == arrayLen - 1 = return $ assocs arr 19 | | otherwise = do 20 | newPos <- getRandomR ( 0, arrayLen - 1 ) 21 | let val = arr ! pos 22 | newVal = arr ! newPos 23 | randomPermute ( arr // [ ( pos, newVal ), ( newPos, val ) ] ) ( pos + 1 ) 24 | where 25 | arrayLen = arrayLength arr 26 | 27 | genPermutedArray :: (RandomGen g) => MArray -> Int -> Rand g [[(Int,Int)]] 28 | genPermutedArray arr count = replicateM count ( randomPermute arr 0 ) 29 | 30 | kArrayLength :: Int 31 | kArrayLength = 50 32 | 33 | kNumTrials :: Int 34 | kNumTrials = 100000 35 | 36 | createHashTable :: [(Int,Int)] -> Map.HashMap (Int,Int) Int 37 | createHashTable xs = Map.fromListWith (+) ( zip xs ( repeat 1 ) ) 38 | 39 | probability :: Map.HashMap (Int,Int) Int -> Int -> Int -> Float 40 | probability table x y = ( (/) `on` fromIntegral ) matchCount kNumTrials 41 | where 42 | matchCount = Map.lookupDefault 0 (y,x) table 43 | 44 | main = do 45 | permutedArrays <- evalRandIO $ genPermutedArray ( createArray kArrayLength ) kNumTrials 46 | let assocs = concat permutedArrays 47 | table = createHashTable assocs 48 | plotAttrs = [Plot3dType ColorMap, CornersToColor Corner1] 49 | plotFunc3d [ZRange (0.014,0.028)] plotAttrs [0..kArrayLength-1] [0..kArrayLength-1] $ probability table 50 | getLine -------------------------------------------------------------------------------- /week2/shuffle/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | 4 | -- General utilities 5 | import Data.Foldable (for_) 6 | import Data.Traversable (for) 7 | import Data.Tuple (swap) 8 | import Control.Monad (replicateM) 9 | -- Arrays 10 | import qualified Data.Vector as V 11 | import Data.Vector (Vector) 12 | import qualified Data.Vector.Mutable as MV 13 | import Data.Array.Unboxed 14 | -- Plotting 15 | import Graphics.Gnuplot.Simple 16 | -- Miscellaneous 17 | import System.Random 18 | import System.Environment (getArgs) 19 | import System.IO.Unsafe (unsafeInterleaveIO) 20 | import Control.Monad.ST (ST) 21 | 22 | 23 | {- | 24 | Shuffle an array by swapping pairs: 25 | 26 | @ 27 | n = array.length 28 | for i in 0..n-1 29 | array.swap(i, random(0, n-1)) 30 | @ 31 | -} 32 | shuffleLoop :: Vector a -> IO (Vector a) 33 | shuffleLoop vec = do 34 | let n = length vec 35 | -- Generate all swap pairs at once 36 | rs <- for [0..n-1] $ \i -> (i,) <$> randomRIO (0,n-1) 37 | -- Apply them all at once with 'modify' 38 | return (V.modify (swapAll rs) vec) 39 | where 40 | swapAll :: [(Int, Int)] -> MV.MVector s a -> ST s () 41 | swapAll xs v = for_ xs $ \(i, j) -> MV.swap v i j 42 | 43 | -- | Shuffle an array and return a list of positions the elements moved to 44 | positions 45 | :: (Vector Int -> IO (Vector Int)) -- ^ Shuffle algorithm to use 46 | -> Int -- ^ Length of array to use 47 | -> IO [(Int, Int)] -- ^ (original position, position after) 48 | positions shuffle n = 49 | map swap . V.toList . V.indexed <$> shuffle (V.enumFromTo 0 (n-1)) 50 | 51 | -- | Count occurrences of all positions in a 2D array 52 | histogram 53 | :: Int -- ^ Length of shuffled array 54 | -> [(Int, Int)] -- ^ Positions in the shuffled array 55 | -> UArray (Int, Int) Int 56 | histogram n xs = accumArray (+) 0 ((0,0),(n-1,n-1)) (map (,1) xs) 57 | 58 | -- | Make a heatmap of a shuffle algorithm 59 | plotShuffle 60 | :: (Vector Int -> IO (Vector Int)) -- ^ Algorithm 61 | -> Int -- ^ Length of array 62 | -> Int -- ^ How many trials to perform 63 | -> IO () 64 | plotShuffle shuffle n kTrials = do 65 | let trial :: IO [(Int, Int)] 66 | trial = positions shuffle n 67 | -- Perform some trials, get a huge list of positions that elements move to 68 | positions <- concat <$> replicateM kTrials (unsafeInterleaveIO trial) 69 | -- Count all those positions 70 | let occurrences = histogram n positions 71 | -- Calculate the probability that 'x' will jump to 'y' 72 | let probJump :: Int -> Int -> Double 73 | probJump x y = fromIntegral (occurrences ! (x,y)) / 74 | fromIntegral kTrials 75 | -- And plot it 76 | let plotAttrs = [Plot3dType ColorMap, CornersToColor Corner1] 77 | plotFunc3d [] plotAttrs [0..n-1] [0..n-1] probJump 78 | 79 | main = do 80 | [n, kTrials] <- map read <$> getArgs 81 | plotShuffle shuffleLoop n kTrials 82 | getLine 83 | -------------------------------------------------------------------------------- /week3/README.md: -------------------------------------------------------------------------------- 1 | ## Week 3 (September 12 – September 18) 2 | 3 | This week's tasks are easier. 4 | 5 | ### 11. Binary conversion `{binary}` 6 | 7 | Convert a number to binary and back: 8 | 9 | ``` 10 | > bin 123 11 | "1111011" 12 | 13 | > dec "1111011" 14 | 123 15 | ``` 16 | 17 | You don't have to handle negative numbers. 18 | 19 | ### 12. Working with expressions `{expr}` 20 | 21 | An arithmetic expression can be represented with the following datatype: 22 | 23 | ``` haskell 24 | data Expr 25 | = Number Int 26 | | Add Expr Expr 27 | | Sub Expr Expr 28 | | Mul Expr Expr 29 | | Div Expr Expr 30 | ``` 31 | 32 | Write functions to print and evaluate expressions: 33 | 34 | ``` 35 | > showExpr (Mul (Number 3) (Add (Number 5) (Number 7))) 36 | "3*(5+7)" 37 | 38 | > evalExpr (Mul (Number 3) (Add (Number 5) (Number 7))) 39 | 36 40 | ``` 41 | 42 | (Use `div` for division.) 43 | 44 | You get bonus points if you only print parentheses when they are needed – e.g. `3+5*7` doesn't need any parentheses. However, it's an optional requirement. 45 | 46 | Also, don't forget about parentheses around negative numbers. 47 | 48 | ### 13. Compute a moving average `{average}` 49 | 50 | A simple [moving average](https://en.wikipedia.org/wiki/Moving_average) is a way to smooth data points. Assume that you have a list: 51 | 52 | ``` 53 | [1,5,3,8,7,9,6] 54 | ``` 55 | 56 | Then a moving average with window size 4 will work like this: 57 | 58 | ``` 59 | average [1] = 1 60 | average [1,5] = 3 61 | average [1,5,3] = 3 62 | average [1,5,3,8] = 4.25 63 | -- now we're starting to lose one element as we go forward 64 | average [5,3,8,7] = 5.75 65 | average [3,8,7,9] = 6.75 66 | average [8,7,9,6] = 7.5 67 | 68 | averaged list = [1,3,3,4.25,5.75,6.75,7.5] 69 | ``` 70 | 71 | Implement moving average with an arbitrary window size: 72 | 73 | ``` 74 | > moving 4 [1, 5, 3, 8, 7, 9, 6] 75 | [1.0, 3.0, 3.0, 4.25, 5.75, 6.75, 7.5] 76 | 77 | > moving 2 [1, 5, 3, 8, 7, 9, 6] 78 | [1.0, 3.0, 4.0, 5.5, 7.5, 8.0, 7.5] 79 | ``` 80 | 81 | ### 14. XOR encryption `{xor}` 82 | 83 | Write a program that encrypts a file by [XORing](https://en.wikipedia.org/wiki/XOR_cipher) it with a key. For instance, if the file is “abracadabra” and the key is “XYZ”, then the result would be 84 | 85 | ``` 86 | abracadabra 87 | XOR XYZXYZXYZXY 88 | = 9;(9:;<88*8 89 | ``` 90 | 91 | It should accept the file name and the key as command-line arguments, and overwrite the file. (Due to the way XOR works, encrypting an already encrypted file will decrypt it.) Use [bytestring](https://hackage.haskell.org/package/bytestring) to read the file, and encode the key as UTF8 (with [`encodeUtf8`](http://hackage.haskell.org/package/text/docs/Data-Text-Encoding.html#v:encodeUtf8)). 92 | 93 | ### 15. Table formatting `{table}` 94 | 95 | The user enters a table of numbers (they're all integers but they can be negative). Your task is to format it nicely by aligning the numbers and making sure you don't output any leading zeroes. An example log: 96 | 97 | ``` 98 | Enter a table: 99 | 01 200 -03 100 | 5 60 700 101 | 080 900 1000 102 | 103 | 1 200 -3 104 | 5 60 700 105 | 80 900 1000 106 | ``` 107 | 108 | You can assume that the table will be rectangular; handling any extra cases is not needed. The end of the input is marked with a blank line (i.e. you should read the rows until you encounter a blank line). 109 | -------------------------------------------------------------------------------- /week3/average/444c43/Main.hs: -------------------------------------------------------------------------------- 1 | movingAvg r [] = [] 2 | movingAvg r list@(x:xs) = 3 | let left = take r list 4 | right = tail list 5 | in firstHalf left ++ secondHalf r right 6 | 7 | firstHalf [] = [] 8 | firstHalf list@(x:xs) = 9 | firstHalf (init list) ++ [(sum list) / fromIntegral (length list)] 10 | 11 | secondHalf a list@(x:xs) 12 | | length list < a = [] 13 | | otherwise = [sum(take a list) / fromIntegral a] ++ secondHalf a (tail list) 14 | -------------------------------------------------------------------------------- /week3/average/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | 3 | moving :: Int -> [Double] -> [Double] 4 | moving _ [] = [] 5 | moving n list 6 | | n <= 0 = list 7 | |otherwise = map average movingList 8 | where 9 | average :: [Double] -> Double 10 | average xs = sum xs / genericLength xs 11 | 12 | movingList :: [[Double]] 13 | movingList = map move $ tail $ inits list 14 | where 15 | move :: [Double] -> [Double] 16 | move x = if length x > n then drop (length x - n) x else x 17 | -------------------------------------------------------------------------------- /week3/average/aneksteind/average.hs: -------------------------------------------------------------------------------- 1 | module Average where 2 | 3 | average :: [Double] -> Double 4 | average (x:xs) = snd $ foldr (\c (n, avg)-> (n+1, (c + (avg * n)) / (n+1))) (1,x) xs 5 | 6 | moving :: Int -> [Double] -> [Double] 7 | moving n xs = foldl (\acc x -> (acc ++ [average (take n $ take x $ drop (x - n) xs)])) [] [1..(length xs)] -------------------------------------------------------------------------------- /week3/average/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import Data.Function 2 | 3 | sampleList = [1,5,3,8,7,9,6] 4 | 5 | moving :: Int -> [Integer] -> [Double] 6 | moving winSize list = zipWith ( (/) `on` fromInteger ) sums winSizes 7 | where 8 | deltas = zipWith (-) list $ replicate winSize 0 ++ list 9 | sums = scanl1 (+) deltas 10 | winSizes= map toInteger ( [1..winSize] ++ repeat winSize ) 11 | 12 | main :: IO () 13 | main = print $ moving 4 sampleList -------------------------------------------------------------------------------- /week3/average/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | {- # Moving Mean 2 | 3 | See an introduction about moving means at 4 | https://en.wikipedia.org/wiki/Moving_average 5 | -} 6 | 7 | main :: IO () 8 | main = do 9 | print $ smm 4 exampleSet 10 | print $ smm 4 exampleSet == [1.0, 3.0, 3.0, 4.25, 5.75, 6.75, 7.5] 11 | print $ smm 2 exampleSet == [1.0, 3.0, 4.0, 5.5, 7.5, 8.0, 7.5] 12 | where 13 | exampleSet = [1,5,3,8,7,9,6] 14 | 15 | 16 | {- | Calculate the simple moving mean. -} 17 | smm :: Int -> [Double] -> [Double] 18 | smm = growMove mean 19 | 20 | 21 | {- | Calculate the mean value of a set. -} 22 | mean :: [Double] -> Double 23 | mean [] = 0 24 | mean xs = sum xs / (realToFrac . length) xs 25 | 26 | 27 | {- | Repeatedly apply f to subsets taken from a moving window. 28 | 29 | The window must first mature before sliding. For example: 30 | 31 | growMove f 4 [1,5,3,8,7,9,6] 32 | 33 | -- Below target size. Grow window by 1 for each step 34 | f [1] = a 35 | f [1,5] = b 36 | f [1,5,3] = c 37 | -- At/above target size. Now repeatedly drop 1 for each step 38 | f [1,5,3,8] = d 39 | f [5,3,8,7] = e 40 | f [3,8,7,9] = f 41 | f [8,7,9,6] = g 42 | 43 | returns [a,b,c,d,e,f,g] 44 | -} 45 | growMove :: ([a] -> a) -> Int -> [a] -> [a] 46 | growMove f windowSize xs 47 | | windowSize <= 0 = [] 48 | | otherwise = go 1 xs 49 | where 50 | go size rest 51 | | size > length rest = [] 52 | | size < windowSize = f (take size rest) : go (size + 1) rest 53 | | otherwise = f (take size rest) : go size (drop 1 rest) 54 | -------------------------------------------------------------------------------- /week3/average/kirikaza/Average.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad (forM_) 4 | import Data.Function (on) 5 | import qualified Data.Sequence as Seq 6 | import Data.Sequence ((<|), Seq(..)) 7 | 8 | main :: IO () 9 | main = forM_ [4,2] $ \window -> do 10 | print $ movingAvgList window [1,5,3,8,7,9,6] 11 | 12 | movingAvgList :: Int -> [Int] -> [Float] 13 | movingAvgList windowSize values = map avg $ formWindows windowSize values 14 | 15 | formWindows :: Int -> [value] -> [Seq value] 16 | formWindows _ [value] = [Seq.singleton value] 17 | formWindows size (firstValue:otherValues) = 18 | scanl (\ seq e -> e <| Seq.take (size-1) seq) 19 | (Seq.singleton firstValue) 20 | otherValues 21 | 22 | avg :: Foldable seq => seq Int -> Float 23 | avg values = sum values /. length values 24 | where (/.) = (/) `on` fromIntegral 25 | -------------------------------------------------------------------------------- /week3/average/kirikaza/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /week3/average/kirikaza/average.cabal: -------------------------------------------------------------------------------- 1 | name: average 2 | version: 0.1.0.0 3 | synopsis: Haskell exercises: Week 3: Task 13: Compute a moving average (by kirikaza) 4 | homepage: https://github.com/neongreen/haskell-ex 5 | author: Kirill Kazakov 6 | maintainer: k@kirikaza.ru 7 | build-type: Simple 8 | cabal-version: >=1.10 9 | 10 | executable average 11 | hs-source-dirs: . 12 | main-is: Average.hs 13 | default-language: Haskell2010 14 | build-depends: base >= 4.7 && < 5 15 | , containers -------------------------------------------------------------------------------- /week3/average/kirikaza/stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.4 2 | packages: 3 | - '.' 4 | -------------------------------------------------------------------------------- /week3/average/kirikaza/try.sh: -------------------------------------------------------------------------------- 1 | #! /bin/bash 2 | 3 | set -e 4 | cd "$(dirname "$0")" 5 | exec stack runghc Average.hs 6 | -------------------------------------------------------------------------------- /week3/average/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | 2 | average :: [Double] -> Double 3 | average lst = sum lst / fromIntegral (length lst) 4 | 5 | moving :: Int -> Int -> [Double] -> [Double] 6 | moving a b = drop (max 0 a) . take b 7 | 8 | movingAverage :: Int -> [Double] -> [Double] 9 | movingAverage w lst = 10 | map (\i -> average $ moving (i - w) i lst) [1..l] 11 | where 12 | l = length lst :: Int 13 | 14 | movingSum :: Int -> [Double] -> [Double] 15 | movingSum w lst = 16 | let 17 | shiftedList = zip lst $ replicate w 0 ++ lst 18 | go :: Double -> [(Double, Double)] -> [Double] 19 | go _ [] = [] 20 | go acc ((toAdd, toDelete):xs) = (acc + toAdd - toDelete) : go (acc + toAdd - toDelete) xs 21 | in 22 | go 0 shiftedList 23 | 24 | movingAverage2 :: Int -> [Double] -> [Double] 25 | movingAverage2 w lst = 26 | zipWith divideBy (movingSum w lst) ([1..w] ++ repeat w) 27 | where 28 | divideBy num len = num / fromIntegral len 29 | 30 | main :: IO () 31 | main = do 32 | let lst = [1,5,3,8,7,9,6] 33 | print $ movingAverage 4 lst 34 | print $ movingAverage2 4 lst 35 | -------------------------------------------------------------------------------- /week3/average/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion 4 | import Criterion.Main 5 | import Data.List 6 | 7 | -- | First approach, which I think is slower, 8 | -- | but how do I benchmark? 9 | average1 :: (Fractional a) => Int -> [a] -> [a] 10 | average1 n xs = averages ++ [sum ws / fromIntegral count] where 11 | (count, ws, averages) = foldl' f (0, [], []) xs 12 | f (_, [], _) e = (1, [e], []) 13 | f (count, ws@(first:rs), as) e 14 | | count < n = (count+1, ws++[e], newas) 15 | | otherwise = (count, rs ++ [e], newas) 16 | where 17 | newas = as ++ [sum ws / fromIntegral count] 18 | 19 | -- | Second approach - use laziness 20 | movingSum2 :: (Fractional a) => Int -> [a] -> [a] 21 | movingSum2 n xs 22 | | n <= 1 = xs 23 | | otherwise = zipWith (+) xs $ movingSum2 (n-1) (0:xs) 24 | 25 | average2 :: (Fractional a) => Int -> [a] -> [a] 26 | average2 n xs = zipWith f (movingSum2 n xs) ([1..n] ++ repeat n) where 27 | f a k = a / fromIntegral k 28 | 29 | 30 | -- | Third approach - 2n additions 31 | movingSum3 :: (Fractional a) => Int -> [a] -> [a] 32 | movingSum3 n xs 33 | | n <= 1 = xs 34 | | otherwise = reverse $ fst $ foldl' f ([], 0) (zip xs $ replicate n 0 ++ xs) 35 | where 36 | f (result, acc) (p, m) = let nacc = acc + p - m in (nacc:result, nacc) 37 | 38 | average3 :: (Fractional a) => Int -> [a] -> [a] 39 | average3 n xs = zipWith f (movingSum3 n xs) ([1..n] ++ repeat n) where 40 | f a k = a / fromIntegral k 41 | 42 | 43 | -- | Artyom's pipeline approach 44 | movingSum4 n xs = 45 | take (length xs) . map (sum . take n) . tails $ replicate (n-1) 0 ++ xs 46 | 47 | average4 :: (Fractional a) => Int -> [a] -> [a] 48 | average4 n xs = zipWith f (movingSum4 n xs) ([1..n] ++ repeat n) where 49 | f a k = a / fromIntegral k 50 | 51 | -- | @thalesmg' refactor of movingSum2 52 | movingSum5 :: (Fractional a) => Int -> [a] -> [a] 53 | movingSum5 w lst = 54 | let 55 | shiftedList = zip lst $ replicate w 0 ++ lst 56 | go _ [] = [] 57 | go acc ((toAdd, toDelete):xs) = (acc + toAdd - toDelete) : go (acc + toAdd - toDelete) xs 58 | in 59 | go 0 shiftedList 60 | 61 | average5 :: (Fractional a) => Int -> [a] -> [a] 62 | average5 n xs = zipWith f (movingSum5 n xs) ([1..n] ++ repeat n) where 63 | f a k = a / fromIntegral k 64 | 65 | -- main :: IO () 66 | -- main = do 67 | -- putStrLn 68 | -- "Enter the size of the window, then a list of Ints, all separated by space" 69 | -- xs <- map (read :: String -> Int) . words <$> getLine 70 | -- print $ moving (head xs) (tail $ map fromIntegral xs) 71 | 72 | main = defaultMain [ 73 | bench "average1" $nf (average1 100) ([1..1000]::[Double]), 74 | bench "average2" $ nf (average2 100) ([1..1000]::[Double]), 75 | bench "average3" $ nf (average3 100) ([1..1000]::[Double]), 76 | bench "average4" $ nf (average4 100) ([1..1000]::[Double]), 77 | bench "average5" $ nf (average5 100) ([1..1000]::[Double])] 78 | -------------------------------------------------------------------------------- /week3/binary/444c43/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | 4 | toBinary :: Int -> [Char] 5 | toBinary a = map intToDigit(divisionByTwo a) 6 | 7 | divisionByTwo :: Integral a => a -> [a] 8 | divisionByTwo 0 = [] 9 | divisionByTwo a = divisionByTwo(a `div` 2) ++ [a `mod` 2] 10 | 11 | toInt :: String -> Int 12 | toInt = foldl' (\acc x -> acc * 2 + digitToInt x) 0 13 | -------------------------------------------------------------------------------- /week3/binary/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Numeric.Natural 3 | import Test.QuickCheck 4 | 5 | bin :: Natural -> String 6 | bin 0 = "0" 7 | bin n = go n "" 8 | where 9 | go :: Natural -> String -> String 10 | go 0 bs = bs 11 | go n bs = go half $ (intToDigit . fromEnum) rest : bs 12 | where 13 | (half, rest) = divMod n 2 14 | 15 | dec :: String -> Natural 16 | dec = sum . zipWith toPower powersOfTwo . reverse 17 | where 18 | toPower :: Natural -> Char -> Natural 19 | toPower pow dig = pow * toEnum (digitToInt dig) 20 | 21 | powersOfTwo :: [Natural] 22 | powersOfTwo = iterate (*2) 1 23 | 24 | procBinary :: Natural -> Property 25 | procBinary n = (dec . bin) n === n 26 | 27 | main :: IO() 28 | main = quickCheck procBinary 29 | -------------------------------------------------------------------------------- /week3/binary/aneksteind/binary.hs: -------------------------------------------------------------------------------- 1 | module Binary where 2 | 3 | import Data.Char 4 | 5 | bin :: Int -> String 6 | bin 0 = ['0'] 7 | bin 1 = ['1'] 8 | bin n = bin (n `div` 2) ++ bin (n `mod` 2) 9 | 10 | dec :: String -> Int 11 | dec = foldl (\acc x -> acc * 2 + (digitToInt x)) 0 -------------------------------------------------------------------------------- /week3/binary/balac/solve.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import Data.Bits 3 | import Data.Char 4 | 5 | bin :: Int -> String 6 | bin 0 = "0" 7 | bin n = reverse $ unfoldr (\x -> if x == 0 then Nothing else Just ( intToDigit ( x .&. 1 ), shift x (-1) ) ) n 8 | 9 | dec :: String -> Int 10 | dec = foldl' ( \acc char -> ( shift acc 1 ) + digitToInt char ) 0 -------------------------------------------------------------------------------- /week3/binary/boccato/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Char 4 | 5 | bin :: Int -> String 6 | bin n = 7 | if q == 0 8 | then show r 9 | else bin q ++ show r 10 | where (q,r) = quotRem n 2 11 | 12 | dec :: String -> Int 13 | dec xs = sum $ zipWith (*) digits pow 14 | where digits = reverse $ map digitToInt xs 15 | pow = iterate (*2) 1 16 | 17 | main :: IO () 18 | main = do 19 | print $ bin 123 20 | print $ dec "1111011" 21 | -------------------------------------------------------------------------------- /week3/binary/jasonkuhrt/BinaryConversion.cabal: -------------------------------------------------------------------------------- 1 | name: BinaryConversion 2 | version: 0.1.0.0 3 | build-type: Simple 4 | -- extra-source-files: 5 | cabal-version: >=1.10 6 | 7 | library 8 | hs-source-dirs: . 9 | exposed-modules: Main 10 | build-depends: base >= 4.7 && < 5, 11 | QuickCheck 12 | default-language: Haskell2010 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/jasonkuhrt/binary 17 | -------------------------------------------------------------------------------- /week3/binary/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | {- # Binary Conversion 2 | 3 | ## Spec 4 | 5 | Convert a positive integer to binary and back. 6 | Ignore negative numbers and fractions. 7 | 8 | ## Examples 9 | 10 | > toBinary 123 11 | "1111011" 12 | 13 | > toDecimal "1111011" 14 | 123 15 | 16 | ## What is a binary number? 17 | 18 | > In mathematics and digital electronics, a binary number is a number 19 | expressed in the binary numeral system or base-2 numeral system which 20 | represents numeric values using two different symbols: typically 0 21 | (zero) and 1 (one). The base-2 system is a positional notation with a 22 | radix of 2. Because of its straightforward implementation in digital 23 | electronic circuitry using logic gates, the binary system is used 24 | internally by almost all modern computers and computer-based devices. 25 | Each digit is referred to as a bit. 26 | -} 27 | 28 | import qualified Data.Char as Char 29 | import Test.QuickCheck ((===)) 30 | import qualified Test.QuickCheck as QS 31 | 32 | type Binary = String 33 | 34 | 35 | 36 | main :: IO () 37 | main = 38 | (QS.quickCheck . QS.property) identityProp 39 | where 40 | identityProp (QS.NonNegative n) = 41 | n === (toDecimal . toBinary) n 42 | 43 | 44 | 45 | {- 46 | Convert binary into decimal. For example: 47 | 48 | > toDecimal "101" 49 | 5 50 | 51 | The following table shows initial increments 52 | and overflow in binary counting. 53 | 54 | DEC BIN POW 55 | 56 | 0 0 2^0 (1) 57 | 1 1 58 | 2 10 2^1 (2) 59 | 3 11 60 | 4 100 2^2 (4) 61 | 5 101 62 | 6 110 63 | 7 111 64 | 8 1000 2^3 (8) 65 | . .... 66 | 67 | Our solution is derived from noting the relationship 68 | between exponetals and significant digits. For example 69 | in 1000b there are three significant digits after "1". So the 70 | value of "1" can be ascertained by raising it to the power of 71 | three. So generally: The value of a binary digit can be found by 72 | raising it to the power of the number of trailing significant 73 | digits. 74 | -} 75 | 76 | toDecimal :: Binary -> Int 77 | toDecimal = 78 | foldl addUp 0 . zip [0..] . reverse 79 | where 80 | addUp val (sigDig, '0') = val 81 | addUp val (sigDig, '1') = val + 2^sigDig 82 | 83 | {- Feedback 84 | 85 | I was shown simpler/more concise ways to implement this. 86 | 87 | 1. Array comprehensions + pattern match 88 | via @neongreen 89 | 90 | This solution leverages array comprehension (1) syntax. 91 | The pattern matching used to draw values out (2) filters 92 | out data that we don't need: significant digits of digit 0 93 | which cotribute zero value to the final sum! 94 | 95 | sum [2^sigDig | (sigDig, '1') <- zip [0..] (reverse xs)] 96 | ^1 ^2 97 | 98 | 2. Math AKA "correct" engineering solution 99 | via @DL 100 | 101 | I love this but given my knowledge/way of thinking I do not think 102 | it would be within ready grasp to arrive at this solution. It 103 | would require at least understanding the correspondance between 104 | powers of the significant digit versus repeated value doubling (1) 105 | plus one or zero (2) neigther of which seem like the kind of insight 106 | I would strike upon. If this was the _only_ way to solve the problem 107 | I assume that I would eventually arrive at it, though :). 108 | 109 | foldl' (\val flag -> val * 2 + digitToInt flag) 0 110 | ^1 ^2 111 | -} 112 | 113 | 114 | 115 | 116 | {- 117 | Convert decimal into binary. For examle: 118 | 119 | > toBinary 10 120 | "1010" 121 | 122 | Repeatedly halve an integer until 0. The remainder of 123 | each division will be used in the result as the 124 | *next-least-significant* (NLS) bit. 125 | 126 | For example: 127 | 128 | Values 10 -> 5 -> 2 -> 1 -> 0 129 | Remainders 0 1 0 1 130 | 131 | Remembering that each reminder is an NLS bit we just 132 | reverse them to get the correct result: 133 | 134 | 1010 135 | -} 136 | 137 | toBinary :: Int -> Binary 138 | toBinary = map Char.intToDigit . reverse . go . divModHalf 139 | where 140 | go (0, remainder) = [remainder] 141 | go (n, remainder) = remainder : go (divModHalf n) 142 | 143 | 144 | 145 | -- General Helpers -- 146 | 147 | divModHalf = (`divMod` 2) 148 | -------------------------------------------------------------------------------- /week3/binary/jasonkuhrt/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 | # http://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-6.17 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.1" 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 -------------------------------------------------------------------------------- /week3/binary/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | 4 | bin :: Integer -> String 5 | bin 0 = "0" 6 | bin n = map (intToDigit . fromIntegral) . reverse . toDigits $ n 7 | where 8 | toDigits 0 = [] 9 | toDigits n = n `mod` 2 : toDigits (n `div` 2) 10 | 11 | dec :: String -> Integer 12 | dec = foldl' (\n digit -> n*2 + fromIntegral (digitToInt digit)) 0 13 | -------------------------------------------------------------------------------- /week3/binary/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import Test.QuickCheck 2 | 3 | bin :: Int -> String 4 | bin n = 5 | let 6 | (q, r) = divMod n 2 7 | in 8 | if q == 0 9 | then show r 10 | else bin q ++ show r 11 | 12 | 13 | dec :: String -> Int 14 | dec b = sum [2^i | (i, '1') <- zip [0..] (reverse b)] 15 | 16 | identity :: Int -> Bool 17 | identity n = n == (dec $ bin n) 18 | 19 | main :: IO () 20 | main = quickCheck (\n -> n >= 0 ==> identity n) 21 | -------------------------------------------------------------------------------- /week3/binary/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | bin :: Int -> String 4 | bin n = bits where 5 | bits = loop n [] 6 | loop x acc = if next == 0 then d:acc else loop next (d:acc) 7 | where 8 | (next, r) = divMod x 2 9 | d = convert r 10 | convert 1 = '1' 11 | convert _ = '0' 12 | 13 | dec :: String -> Int 14 | dec s = foldr f 0 (zip ds [0..]) where 15 | ds = map convert (reverse s) 16 | convert '1' = 1 17 | convert _ = 0 18 | f (d, i) acc = acc + d*2^i 19 | 20 | main :: IO () 21 | main = undefined 22 | -------------------------------------------------------------------------------- /week3/expr/alviprofluvium/Expr.hs: -------------------------------------------------------------------------------- 1 | module Expr where 2 | 3 | data Expr 4 | = Number Int 5 | | Add Expr Expr 6 | | Sub Expr Expr 7 | | Mul Expr Expr 8 | | Div Expr Expr 9 | 10 | 11 | showExpr :: Expr -> String 12 | showExpr expr = case expr of 13 | Number n -> if n < 0 then "(" ++ show n ++ ")" else show n 14 | Add a b -> showExpr a ++ "+" ++ showExpr b 15 | Sub a b -> showExpr a ++ "-" ++ format b 16 | Mul a b -> format a ++ "*" ++ format b 17 | Div a b -> format a ++ "/" ++ parens b 18 | where 19 | parens e = case e of 20 | Number _ -> showExpr e 21 | _ -> "(" ++ showExpr e ++ ")" 22 | format e = case e of 23 | Add _ _ -> "(" ++ showExpr e ++ ")" 24 | Sub _ _ -> "(" ++ showExpr e ++ ")" 25 | _ -> showExpr e 26 | 27 | 28 | evalExpr :: Expr -> Int 29 | evalExpr (Number n) = n 30 | evalExpr (Add a b) = evalExpr a + evalExpr b 31 | evalExpr (Sub a b) = evalExpr a - evalExpr b 32 | evalExpr (Mul a b) = evalExpr a * evalExpr b 33 | evalExpr (Div a b) = evalExpr a `div` evalExpr b 34 | 35 | 36 | -------------------------------------------------------------------------------- /week3/expr/aneksteind/expr.hs: -------------------------------------------------------------------------------- 1 | module Expr where 2 | 3 | data Expr = Number Int 4 | | Add Expr Expr 5 | | Sub Expr Expr 6 | | Mul Expr Expr 7 | | Div Expr Expr 8 | 9 | showExpr :: Expr -> String 10 | showExpr (Number i) = show i 11 | showExpr (Add e1 e2) = showExpr e1 ++ "+" ++ showExpr e2 12 | showExpr (Sub e1 e2) = showExpr e1 ++ "-" ++ showExpr e2 13 | showExpr (Mul e1 e2) = showExpr e1 ++ "*" ++ showExpr e2 14 | showExpr (Div e1 e2) = showExpr e1 ++ "/" ++ showExpr e2 15 | 16 | evalExpr :: Expr -> Int 17 | evalExpr (Number i) = i 18 | evalExpr (Add e1 e2) = evalExpr e1 + evalExpr e2 19 | evalExpr (Sub e1 e2) = evalExpr e1 - evalExpr e2 20 | evalExpr (Mul e1 e2) = evalExpr e1 * evalExpr e2 21 | evalExpr (Div e1 e2) = evalExpr e1 `div` evalExpr e2 -------------------------------------------------------------------------------- /week3/expr/balac/solve.hs: -------------------------------------------------------------------------------- 1 | 2 | data Expr 3 | = Number Int 4 | | Add Expr Expr 5 | | Sub Expr Expr 6 | | Mul Expr Expr 7 | | Div Expr Expr 8 | deriving( Show ) 9 | 10 | sampleExpr = Mul (Number (-2)) ( Mul (Number 3) (Add (Number 5) (Number 7)) ) 11 | 12 | 13 | evalExpr :: Expr -> Int 14 | evalExpr ( Number n ) = n 15 | evalExpr ( Add l r ) = ( evalExpr l ) + ( evalExpr r ) 16 | evalExpr ( Sub l r ) = ( evalExpr l ) - ( evalExpr r ) 17 | evalExpr ( Mul l r ) = ( evalExpr l ) * ( evalExpr r ) 18 | evalExpr ( Div l r ) = ( evalExpr l ) `div` ( evalExpr r ) 19 | 20 | 21 | showExpr :: Expr -> String 22 | showExpr ( Number n ) = if n < 0 then concat [ "(", show n , ")" ] else show n 23 | showExpr ( Add l r ) = concat [ showExpr l, "+", showExpr r ] 24 | showExpr ( Sub l r ) = concat [ showExpr l, "-", showExpr r ] 25 | 26 | showExpr ( Mul l@( Number _ ) r@( Number _ ) ) = concat [ showExpr l, "*", showExpr r ] 27 | showExpr ( Mul l@( Number _ ) r ) = concat [ showExpr l, "*(", showExpr r, ")" ] 28 | showExpr ( Mul l r@( Number _ ) ) = concat [ "(", showExpr l, ")*", showExpr r ] 29 | showExpr ( Mul l r ) = concat [ "(", showExpr l, ")*(", showExpr r, ")" ] 30 | 31 | showExpr ( Div l@( Number _ ) r@( Number _ ) ) = concat [ showExpr l, "/", showExpr r ] 32 | showExpr ( Div l@( Number _) r ) = concat [ showExpr l, "/(", showExpr r, ")" ] 33 | showExpr ( Div l r@( Number _ ) ) = concat [ "(", showExpr l, ")/", showExpr r ] 34 | showExpr ( Div l r ) = concat [ "(", showExpr l, ")/(", showExpr r, ")" ] 35 | 36 | main = do 37 | print sampleExpr 38 | print $ evalExpr sampleExpr 39 | print $ showExpr sampleExpr -------------------------------------------------------------------------------- /week3/expr/maverickchaser/Main.hs: -------------------------------------------------------------------------------- 1 | data Expr 2 | = Number Int 3 | | Add Expr Expr 4 | | Sub Expr Expr 5 | | Mul Expr Expr 6 | | Div Expr Expr 7 | 8 | data Operation = DoAdd | DoSub | DoMul | DoDiv | DoNothing deriving (Eq, Show) 9 | lastOp :: Expr -> Operation 10 | lastOp (Number a) = DoNothing 11 | lastOp (Add a b) = DoAdd 12 | lastOp (Sub a b) = DoSub 13 | lastOp (Mul a b) = DoMul 14 | lastOp (Div a b) = DoDiv 15 | 16 | enclose :: String -> String 17 | enclose a = "(" ++ a ++ ")" 18 | 19 | encloseIfNeed a 20 | | lastOp a == DoAdd || lastOp a == DoSub = enclose 21 | | otherwise = id 22 | 23 | showExpr :: Expr -> String 24 | showExpr (Number a) = show a 25 | showExpr (Add a b) = showExpr a ++ "+" ++ showExpr b 26 | showExpr (Sub a b) = showExpr a ++ "-" ++ showExpr b 27 | showExpr (Mul a b) = let showA = encloseIfNeed a $ showExpr a 28 | showB = encloseIfNeed b $ showExpr b 29 | in 30 | showA ++ "*" ++ showB 31 | showExpr (Div a b) = let showA = encloseIfNeed a $ showExpr a 32 | showB = (if lastOp b == DoNothing then id else enclose) $ showExpr b 33 | in 34 | showA ++ "/" ++ showB 35 | 36 | evalExpr :: Expr -> Int 37 | evalExpr (Number a) = a 38 | evalExpr (Add a b) = evalExpr a + evalExpr b 39 | evalExpr (Sub a b) = evalExpr a - evalExpr b 40 | evalExpr (Mul a b) = evalExpr a * evalExpr b 41 | evalExpr (Div a b) = evalExpr a `div` evalExpr b 42 | 43 | -------------------------------------------------------------------------------- /week3/expr/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | data Expr 2 | = Number Int 3 | | Add Expr Expr 4 | | Sub Expr Expr 5 | | Mul Expr Expr 6 | | Div Expr Expr 7 | deriving Show 8 | 9 | evalExpr :: Expr -> Int 10 | evalExpr (Number n) = n 11 | evalExpr (Add a b) = evalExpr a + evalExpr b 12 | evalExpr (Sub a b) = evalExpr a - evalExpr b 13 | evalExpr (Mul a b) = evalExpr a * evalExpr b 14 | evalExpr (Div a b) = evalExpr a `div` evalExpr b 15 | 16 | prec :: Expr -> Int 17 | prec e = case e of 18 | Number{} -> 9 19 | Add{} -> 1; Sub{} -> 1 20 | Mul{} -> 2; Div{} -> 2 21 | 22 | assoc :: Expr -> Bool 23 | assoc e = case e of 24 | Number{} -> error "assoc: called on Number" 25 | Add{} -> True; Sub{} -> False 26 | Mul{} -> True; Div{} -> False 27 | 28 | sameOp :: Expr -> Expr -> Bool 29 | sameOp a b = case (a,b) of 30 | (Number{}, Number{}) -> error "sameOp: called on Number" 31 | (Add{}, Add{}) -> True 32 | (Sub{}, Sub{}) -> True 33 | (Mul{}, Mul{}) -> True 34 | (Div{}, Div{}) -> True 35 | _ -> False 36 | 37 | showExpr :: Expr -> String 38 | showExpr e = case e of 39 | Number n -> parens (n<0) (show n) 40 | Add a b -> showLeft a ++ "+" ++ showRight b 41 | Sub a b -> showLeft a ++ "-" ++ showRight b 42 | Mul a b -> showLeft a ++ "*" ++ showRight b 43 | Div a b -> showLeft a ++ "/" ++ showRight b 44 | where 45 | showLeft x = parens (prec x < prec e) (showExpr x) 46 | showRight x = parens (prec x < prec e || 47 | prec x == prec e && not (assoc x && sameOp x e)) 48 | (showExpr x) 49 | 50 | parens :: Bool -> String -> String 51 | parens b s = if b then "(" ++ s ++ ")" else s 52 | -------------------------------------------------------------------------------- /week3/expr/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | data Expr 2 | = Number Int 3 | | Add Expr Expr 4 | | Sub Expr Expr 5 | | Mul Expr Expr 6 | | Div Expr Expr 7 | 8 | showExpr :: Expr -> String 9 | showExpr expr = case expr of 10 | Add e1 e2 -> showExpr e1 ++ "+" ++ showExpr e2 11 | Sub e1 e2 -> showExpr e1 ++ "-" ++ parenExpr e2 12 | Mul e1 e2 -> parenExpr e1 ++ "*" ++ parenExpr e2 13 | Div e1 e2 -> parenExpr e1 ++ "/" ++ fullParen e2 14 | Number n -> if n < 0 then "(" ++ show n ++ ")" else show n 15 | where 16 | parenExpr expr' = case expr' of 17 | Add _ _ -> "(" ++ showExpr expr' ++ ")" 18 | Sub _ _ -> "(" ++ showExpr expr' ++ ")" 19 | _ -> showExpr expr' 20 | fullParen expr' = case expr' of 21 | Number _ -> showExpr expr' 22 | _ -> "(" ++ showExpr expr' ++ ")" 23 | 24 | evalExpr :: Expr -> Int 25 | evalExpr expr = case expr of 26 | Add e1 e2 -> evalExpr e1 + evalExpr e2 27 | Sub e1 e2 -> evalExpr e1 - evalExpr e2 28 | Mul e1 e2 -> evalExpr e1 * evalExpr e2 29 | Div e1 e2 -> evalExpr e1 `div` evalExpr e2 30 | Number n -> n 31 | 32 | main :: IO () 33 | main = do 34 | print $ showExpr (Mul (Number 3) (Add (Number 5) (Number 7))) 35 | print $ evalExpr (Mul (Number 3) (Add (Number 5) (Number 7))) 36 | -------------------------------------------------------------------------------- /week3/expr/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Function (on) 4 | 5 | data Expr 6 | = Number Int 7 | | Add Expr Expr 8 | | Sub Expr Expr 9 | | Mul Expr Expr 10 | | Div Expr Expr 11 | 12 | evalExpr :: Expr -> Int 13 | evalExpr e = case e of 14 | Number n -> n 15 | Add e1 e2 -> on (+) evalExpr e1 e2 16 | Sub e1 e2 -> on (-) evalExpr e1 e2 17 | Mul e1 e2 -> on (*) evalExpr e1 e2 18 | Div e1 e2 -> on div evalExpr e1 e2 19 | 20 | 21 | isAddition :: Expr -> Bool 22 | isAddition e = case e of 23 | Add _ _ -> True 24 | Sub _ _ -> True 25 | _ -> False 26 | 27 | isMultiplication :: Expr -> Bool 28 | isMultiplication e = case e of 29 | Mul _ _ -> True 30 | Div _ _ -> True 31 | _ -> False 32 | 33 | 34 | showExpr :: Expr -> String 35 | showExpr e = case e of 36 | Number n -> if n < 0 then '(' : show n ++ ")" else show n 37 | Add e1 e2 -> showExpr e1 ++ '+' : showExpr e2 38 | Sub e1 e2 -> showExpr e1 ++ '-' : wrapAdd e2 39 | Mul e1 e2 -> wrapAdd e1 ++ '*' : wrapAdd e2 40 | Div e1 e2 -> wrapAdd e1 ++ " div " ++ wrapDiv e2 41 | where 42 | wrap e = '(' : showExpr e ++ ")" 43 | wrapAdd e = if isAddition e then wrap e else showExpr e 44 | wrapDiv e = if isAddition e || isMultiplication e 45 | then wrap e else showExpr e 46 | 47 | -- | Turn +- into - and -- into +. 48 | showExprPro :: Expr -> String 49 | showExprPro e = str where 50 | (minus, str) = helper e 51 | helper e = case e of 52 | Number n -> (n < 0, show n) 53 | Add e1 e2 -> (minus1, str1 ++ if minus2 then str2 else '+' : str2) 54 | where 55 | (minus1, str1) = helper e1 56 | (minus2, str2) = helper e2 57 | Sub e1 e2 -> (minus1, str1 ++ if minus2 then '+':tail str2 else '-' : str2) 58 | where 59 | (minus1, str1) = helper e1 60 | (tmpminus2, tmp2) = helper e2 61 | (minus2, str2) = if isAddition e2 62 | then (False, wrap tmp2) else (tmpminus2, tmp2) 63 | Mul e1 e2 -> (minus1 && (not . isAddition) e1, str1 ++ '*' : str2) 64 | where 65 | (minus1, tmp1) = helper e1 66 | (minus2, tmp2) = helper e2 67 | str1 = if isAddition e1 then wrap tmp1 else tmp1 68 | str2 = if minus2 || isAddition e2 then wrap tmp2 else tmp2 69 | Div e1 e2 -> (minus1 && (not . isAddition) e1, str1 ++ " div " ++ str2) 70 | where 71 | (minus1, tmp1) = helper e1 72 | (minus2, tmp2) = helper e2 73 | str1 = if isAddition e1 then wrap tmp1 else tmp1 74 | str2 = if minus2 || isAddition e2 || isMultiplication e2 75 | then wrap tmp2 else tmp2 76 | where 77 | wrap s = '(' : s ++ ")" 78 | 79 | main :: IO () 80 | main = undefined 81 | -------------------------------------------------------------------------------- /week3/table/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | 3 | spacing :: [[String]] -> [Int] 4 | spacing = map (maximum . width) . transpose 5 | where 6 | width :: [String] -> [Int] 7 | width = map length 8 | 9 | format :: [String] -> [String] 10 | format lines = map (unwords . zipWith spaced (spacing table)) table 11 | where 12 | table :: [[String]] 13 | table = map (map (show . (read::String -> Int)) . words) lines 14 | 15 | spaced :: Int -> String -> String 16 | spaced width xs = replicate (width - length xs) ' ' ++ xs 17 | 18 | getLines :: IO [String] 19 | getLines = do 20 | line <- getLine 21 | if null line then return [] else (line:) <$> getLines 22 | 23 | main :: IO () 24 | main = do 25 | putStrLn "Enter a table:" 26 | lines <- getLines 27 | mapM_ putStrLn (format lines) 28 | -------------------------------------------------------------------------------- /week3/table/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | import Data.List 4 | 5 | main = do 6 | putStrLn "Enter a table:" 7 | table :: [[Int]] <- map (map read . words) <$> readUntilBlank 8 | putStr . unlines . map (intercalate " ") $ padTable (map (map show) table) 9 | 10 | readUntilBlank :: IO [String] 11 | readUntilBlank = do 12 | line <- getLine 13 | if null line then return [] else (line:) <$> readUntilBlank 14 | 15 | pad :: Int -> String -> String 16 | pad n s = replicate (n - length s) ' ' ++ s 17 | 18 | padTable :: [[String]] -> [[String]] 19 | padTable table = map padRow table 20 | where 21 | columns = transpose table 22 | columnWidths = map (maximum . map length) columns 23 | padRow row = zipWith pad columnWidths row 24 | -------------------------------------------------------------------------------- /week3/table/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | numChars :: Int -> Int 2 | numChars = (+1) . truncate . logBase 10 . fromIntegral . abs . minusSign 3 | where 4 | minusSign n = if n < 0 then 10*n else n -- to account for the minus sign 5 | 6 | numCharsTable :: [[Int]] -> [Int] 7 | numCharsTable entries = 8 | let 9 | nums' = map numChars 10 | in 11 | foldr1 (zipWith max) $ map nums' entries 12 | 13 | -- Pads an Int with spaces to the left 14 | padNumber :: Int -- padding 15 | -> Int -- number 16 | -> String 17 | padNumber pad n = 18 | replicate s ' ' ++ show n 19 | where 20 | s = 1 + pad - numChars n -- 1 extra space to separate columns 21 | 22 | padRow :: [Int] -> [Int] -> String 23 | padRow pads row = 24 | concatMap (uncurry padNumber) $ zip pads row -- uncurry makes the function act on a tuple 25 | 26 | main :: IO () 27 | main = do 28 | putStrLn "Enter a table:" 29 | table <- loop 30 | putStrLn "" 31 | let padding = numCharsTable table 32 | rowToString = padRow padding 33 | mapM_ (putStrLn . rowToString) table 34 | where 35 | loop :: IO [[Int]] 36 | loop = do 37 | row <- map (read :: String -> Int) . words <$> getLine 38 | if null row 39 | then return [] 40 | else do 41 | row' <- loop 42 | return $ row : row' 43 | -------------------------------------------------------------------------------- /week3/table/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | import Text.Read 5 | 6 | data Pad = L | R deriving (Eq) 7 | 8 | normalize :: [[String]] -> (Int, Int, [Maybe Int]) 9 | normalize ss = (length ss, n, concatMap f rows) 10 | where 11 | cols = map length ss 12 | n = maximum cols 13 | rows = zip cols ss 14 | f (j, row) = (map readMaybe row::[Maybe Int]) ++ replicate (n-j) Nothing 15 | 16 | 17 | lengthMaybeInt :: Maybe Int -> Int 18 | lengthMaybeInt = length . showMaybeInt 19 | 20 | showMaybeInt :: Maybe Int -> String 21 | showMaybeInt = maybe "" show 22 | 23 | pad p n s = 24 | case p of 25 | L -> padding ++ s 26 | R -> s ++ padding 27 | where 28 | padding = replicate (n - length s) ' ' 29 | 30 | showTable :: [[String]] -> String 31 | showTable numbers = 32 | concatMap f [(i, j, table !! (i*n+j)) | i<-[0..m-1], j <- [0..n-1]] 33 | where 34 | (m, n, table) = normalize numbers 35 | widths = [maximum (map lengthMaybeInt $ getCol j) | j <- [0..n-1]] 36 | getCol j = [table !! (i*n+j) | i <- [0..m-1]] 37 | f (i, j, mi) 38 | = pad (if j == 0 then R else L) (widths !! j) (showMaybeInt mi) 39 | ++ if j == (n - 1) then "\n" else " " 40 | 41 | getTable :: IO [[String]] 42 | getTable = loop (return []) where 43 | loop rows = do 44 | row <- getLine 45 | case row of 46 | [] -> rows 47 | _ -> loop $ (++ [words row]) <$> rows 48 | 49 | main :: IO () 50 | main = do 51 | putStrLn "Enter a table:" 52 | table <- getTable 53 | putStrLn $ showTable table 54 | -------------------------------------------------------------------------------- /week3/xor/alviprofluvium/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import System.Environment 3 | import System.Directory 4 | import Data.Bits 5 | import qualified Data.Text as T 6 | import Data.Text.Encoding 7 | import qualified Data.ByteString.Lazy as BS 8 | 9 | encrypt :: BS.ByteString -> BS.ByteString -> BS.ByteString 10 | encrypt txt key = BS.pack $ BS.zipWith xor txt rollingKey 11 | where 12 | rollingKey = BS.cycle key 13 | 14 | main :: IO () 15 | main = do 16 | [fileName, key] <- getArgs 17 | handle <- openBinaryFile fileName ReadMode 18 | contents <- BS.hGetContents handle 19 | 20 | (tempName, tempHandle) <- openBinaryTempFile "." "temp" 21 | 22 | BS.hPut tempHandle $ encrypt contents $ (BS.fromStrict . encodeUtf8 . T.pack) key 23 | 24 | hClose handle 25 | hClose tempHandle 26 | 27 | renameFile tempName fileName 28 | -------------------------------------------------------------------------------- /week3/xor/balac/Main.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import System.IO 3 | import System.IO.Temp 4 | import System.Directory 5 | 6 | import qualified Data.Text as T 7 | import Data.Text.Encoding (encodeUtf8) 8 | 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Lazy as BL 11 | import Data.Bits 12 | import Data.Word 13 | 14 | encrypt :: BL.ByteString -> BS.ByteString -> BL.ByteString 15 | encrypt contents key = BL.pack $ zipWith xor ( BL.unpack contents ) ( cycle $ BS.unpack key ) 16 | 17 | main :: IO () 18 | main = do 19 | [inpFilename, key] <- getArgs 20 | inpHandle <- openBinaryFile inpFilename ReadMode 21 | contents <- BL.hGetContents inpHandle 22 | let encKey = encodeUtf8 $ T.pack key 23 | encData = encrypt contents encKey 24 | (tmpPath, tmpHandle) <- openBinaryTempFile "." "tmpEnc" 25 | BL.hPut tmpHandle encData 26 | hClose tmpHandle 27 | hClose inpHandle 28 | renameFile tmpPath inpFilename -------------------------------------------------------------------------------- /week3/xor/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {- README 3 | 4 | -- XOR Encryption 5 | 6 | -- Spec 7 | 8 | Write a program that encrypts a file by XORing it with a key. For instance: 9 | 10 | Key "XYZ" 11 | Contents "abracadabra" 12 | XOR XYZXYZXYZXY 13 | = 9;(9:;<88*8 14 | 15 | * It should accept the file name and the key as command-line arguments 16 | * Use bytestring to read the file 17 | * Encode the key as UTF8 (with encodeUtf8) 18 | * Overwrite the file with encryped variant 19 | 20 | -- Notes 21 | 22 | Due to the way XOR works, encrypting an already encrypted file will decrypt 23 | it. Learn more about XOR Ciphers at en.wikipedia.org/wiki/xor_cipher. 24 | -} 25 | 26 | 27 | 28 | module Main where 29 | 30 | import qualified Data.Bits as Bits 31 | import qualified System.Environment as Env 32 | import Data.ByteString.Lazy (ByteString) 33 | import qualified Data.ByteString.Lazy as BSL 34 | import qualified Data.ByteString.Lazy.Char8 as BSL 35 | import Data.Text.Lazy (Text) 36 | import qualified Data.Text.Lazy as TL 37 | import qualified Data.Text.Lazy.Encoding as TL 38 | 39 | 40 | 41 | {- | CLI to de/encrypt a file. 42 | 43 | xor KEY FILEPATH 44 | 45 | Multiple runs on the same file toggles encryption due to the nature of XOR. 46 | NOTE Crashes if CLI arguments are not given correctly. 47 | 48 | Example: 49 | @ 50 | > xor blah ~/test-file.md 51 | 52 | ==> Reading File 53 | ==> Flipping Encryption 54 | ==> Writing File 55 | ==> Done 56 | ==> Result: 57 | 58 | HMkL2 59 | @ 60 | -} 61 | main :: IO () 62 | main = do 63 | [keyString, filePath] <- Env.getArgs 64 | let key = (TL.encodeUtf8 . TL.pack) keyString 65 | endecryptFile key filePath 66 | 67 | 68 | 69 | {- | De/encrypt a file. 70 | 71 | NOTE Crashes if file does not exist -} 72 | endecryptFile :: ByteString -> String -> IO () 73 | endecryptFile key filePath = do 74 | putStrLn "==> Reading File" 75 | contents <- BSL.readFile filePath 76 | putStrLn "==> Flipping Encryption" 77 | let encrypted = encrypt key contents 78 | putStrLn "==> Writing File" 79 | -- Force the lazily read file to be read otherwise we will attempt to write 80 | -- over a file before we've even read it! For example on OSX there is an 81 | -- error stating the file is locked (because OS locks the file on read). 82 | seq (BSL.length contents) (BSL.writeFile filePath encrypted) 83 | putStrLn "==> Done" 84 | putStrLn "==> Result:\n" 85 | BSL.putStrLn encrypted 86 | 87 | 88 | 89 | {- | Encrypt a string via key+XOR+key. -} 90 | encrypt :: ByteString -> ByteString -> ByteString 91 | encrypt key contents = 92 | BSL.pack (BSL.zipWith Bits.xor (BSL.cycle key) contents) 93 | 94 | {- | Decrypt a string via key+XOR. 95 | 96 | Because of how XOR works decrypt is just `encrypt` run on something 97 | already encrypted. -} 98 | decrypt :: ByteString -> ByteString -> ByteString 99 | decrypt = encrypt 100 | 101 | 102 | 103 | {- | Minimal de/encryption test. -} 104 | test :: IO () 105 | test = do 106 | let key = "XYZ" 107 | let contents = "abracadabra" 108 | let encryptedExpected = "9;(9:;<88*8" 109 | let encrypted = encrypt key contents 110 | let decrypted = decrypt key encrypted 111 | print encrypted 112 | print $ encrypted == encryptedExpected 113 | print decrypted 114 | print $ decrypted == contents 115 | -------------------------------------------------------------------------------- /week3/xor/jasonkuhrt/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 | # http://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-7.0 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.1" 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 -------------------------------------------------------------------------------- /week3/xor/jasonkuhrt/xor.cabal: -------------------------------------------------------------------------------- 1 | name: xor 2 | category: App 3 | version: 0.0.0.1 4 | build-type: Simple 5 | -- extra-source-files: 6 | cabal-version: >=1.10 7 | 8 | executable xor 9 | hs-source-dirs: . 10 | main-is: Main.hs 11 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 12 | build-depends: base, text, bytestring 13 | default-language: Haskell2010 14 | 15 | source-repository head 16 | type: git 17 | location: https://github.com/jasonkuhrt/xor 18 | -------------------------------------------------------------------------------- /week3/xor/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import System.Environment 2 | import System.IO 3 | import qualified Data.Text.Lazy.Encoding as TLE 4 | import qualified Data.Text.Lazy as TL 5 | import qualified Data.ByteString.Lazy as L 6 | import qualified Data.ByteString as BS 7 | import qualified Data.Bits as B 8 | 9 | myXor :: L.ByteString -> BS.ByteString -> BS.ByteString 10 | myXor key text = 11 | L.toStrict . L.pack $ L.zipWith B.xor (L.cycle key) (L.fromStrict text) 12 | 13 | main :: IO () 14 | main = do 15 | [key, file] <- getArgs 16 | handle <- openFile file ReadMode 17 | contents <- BS.hGetContents handle 18 | print "Starting to XOR file..." 19 | let byteKey = TLE.encodeUtf8 . TL.pack $ key 20 | xored = myXor byteKey contents 21 | print "Going to write..." 22 | handle2 <- openFile file WriteMode 23 | BS.hPut handle2 xored 24 | hClose handle2 25 | print "Finished XORing file." 26 | -------------------------------------------------------------------------------- /week3/xor/thalesmg/test: -------------------------------------------------------------------------------- 1 | abracadabra 2 | -------------------------------------------------------------------------------- /week3/xor/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Bits (xor) 4 | import Data.ByteString (ByteString) 5 | import qualified Data.ByteString as BS 6 | import qualified Data.Text as T 7 | import Data.Text.Encoding (encodeUtf8) 8 | import System.Environment (getArgs) 9 | 10 | encode :: ByteString -> ByteString -> ByteString 11 | encode key str = BS.pack $ BS.zipWith xor str repeatedkey where 12 | ls = BS.length str 13 | lk = BS.length key 14 | repeatedkey = BS.concat $ replicate (1 + div ls lk) key 15 | 16 | main :: IO () 17 | main = do 18 | [filepath, key] <- getArgs 19 | str <- BS.readFile filepath 20 | BS.writeFile filepath $ encode (encodeUtf8 $ T.pack key) str 21 | -------------------------------------------------------------------------------- /week4/json-print/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | {- README 2 | 3 | -- Code Kata : JSON Print 4 | 5 | Define a data type for JSON and print it as JSON (without indentation). 6 | Don't forget that you should support floating-point numbers and escaping in 7 | strings. 8 | -} 9 | module Main where 10 | 11 | import Data.Map (Map) 12 | import qualified Data.Map as Map 13 | import qualified Data.List as List 14 | import qualified Data.Char as Char 15 | import Text.Printf (printf) 16 | 17 | 18 | 19 | 20 | data JSON = 21 | Nil 22 | | B Bool 23 | | S String 24 | | N Double 25 | | L [JSON] 26 | | O (Map String JSON) 27 | deriving (Show) 28 | 29 | 30 | 31 | {- | Stringify a JSON type to a valid JSON string. -} 32 | stringify :: JSON -> String 33 | 34 | stringify Nil = "null" 35 | 36 | stringify (B True) = "true" 37 | stringify (B False) = "false" 38 | 39 | stringify (S string) = stringifyString string 40 | 41 | stringify (N number) = stringifyNumber number where 42 | stringifyNumber :: Double -> String 43 | stringifyNumber n 44 | | remainder /= 0 = show n 45 | | otherwise = show integer 46 | where 47 | (integer, remainder) = properFraction n :: (Integer, Double) 48 | 49 | stringify (L list) = 50 | wrap "[]" 51 | . List.intercalate ", " 52 | . fmap stringify 53 | $ list 54 | 55 | stringify (O object) = 56 | wrap "{}" 57 | . List.intercalate ", " 58 | . Map.elems 59 | . Map.mapWithKey stringifyKeyValue 60 | $ object 61 | where 62 | stringifyKeyValue :: String -> JSON -> String 63 | stringifyKeyValue k v = 64 | stringifyString k ++ ":" ++ stringify v 65 | 66 | 67 | 68 | -- String Handling -- 69 | 70 | stringifyString :: String -> String 71 | stringifyString = wrap "\"" . escapeString 72 | 73 | escapeString :: String -> String 74 | escapeString = go where 75 | go "" = "" 76 | 77 | go ('\\' :s) = "\\\\" ++ go s 78 | go ('"' :s) = "\\\"" ++ go s 79 | 80 | go ('\b' :s) = "\\b" ++ go s 81 | go ('\f' :s) = "\\f" ++ go s 82 | go ('\n' :s) = "\\n" ++ go s 83 | go ('\r' :s) = "\\r" ++ go s 84 | go ('\t' :s) = "\\t" ++ go s 85 | 86 | go (c :s) 87 | | Char.isControl c = (printf "\\u%04x" . Char.ord) c ++ go s 88 | 89 | go (c :s) = c : go s 90 | 91 | 92 | 93 | -- Helpers -- 94 | 95 | wrap :: String -> String -> String 96 | wrap [end] s = [end] ++ s ++ [end] 97 | wrap [start,end] s = [start] ++ s ++ [end] 98 | wrap _ s = s 99 | 100 | 101 | 102 | -- Test -- 103 | 104 | main :: IO () 105 | main = putStrLn . stringify $ sample 106 | 107 | sample :: JSON 108 | sample = 109 | O . Map.fromList $ [ 110 | ("1", S "\1foo\nbar\xFFFF"), 111 | ("a", N 1), 112 | ("b", N 2.2), 113 | ("c", O . Map.fromList $ [ 114 | ("ca", S "foo"), 115 | ("cb", Nil) 116 | ]), 117 | ("d", N 2.0), 118 | ("e", N 2.03), 119 | ("f", L [N 1, S "bar", Nil, L [], O Map.empty]), 120 | ("g", S "5 \\ 5"), 121 | ("h", S "5 \\\\ 5"), 122 | ("i", S "He said \"foo\"!"), 123 | ("j", S "\\foobar") 124 | ] 125 | -------------------------------------------------------------------------------- /week4/json-print/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.List 2 | import qualified Data.Map as M 3 | import Data.Map (Map) 4 | import Numeric (showHex) 5 | 6 | 7 | data JSON 8 | = JNull 9 | | JBool Bool 10 | | JNumber Double 11 | | JString String 12 | | JArray [JSON] 13 | | JObject (Map String JSON) 14 | deriving (Eq, Ord, Show) 15 | 16 | encode :: JSON -> String 17 | encode JNull = "null" 18 | encode (JBool b) = if b then "true" else "false" 19 | encode (JNumber x) = show x 20 | encode (JString x) = escape x 21 | encode (JArray xs) = "[" ++ intercalate "," (map encode xs) ++ "]" 22 | encode (JObject m) = 23 | "{" ++ intercalate "," (map showPair (M.toList m)) ++ "}" 24 | where showPair (k,v) = escape k ++ ":" ++ encode v 25 | 26 | escape :: String -> String 27 | escape s = "\"" ++ concatMap escapeChar s ++ "\"" 28 | where 29 | escapeChar '"' = "\\\"" 30 | escapeChar '\\' = "\\\\" 31 | escapeChar '\b' = "\\b" 32 | escapeChar '\f' = "\\f" 33 | escapeChar '\n' = "\\n" 34 | escapeChar '\r' = "\\r" 35 | escapeChar '\t' = "\\t" 36 | escapeChar x | x < '\x20' = escapeUnicode x 37 | escapeChar x = [x] 38 | 39 | escapeUnicode :: Char -> String 40 | escapeUnicode c = "\\u" ++ replicate (4-length h) '0' ++ h 41 | where 42 | h = showHex (fromEnum c) "" 43 | 44 | main :: IO () 45 | main = do 46 | -- Examples stolen from @thalesmg's solution 47 | putStrLn . encode $ JNull 48 | putStrLn . encode $ JBool True 49 | putStrLn . encode $ JNumber 10.123 50 | putStrLn . encode $ JString "hello" 51 | putStrLn . encode $ JArray [JNull, JBool False, JArray []] 52 | putStrLn . encode $ JObject M.empty 53 | putStrLn . encode $ JObject $ M.fromList [ 54 | ("fi\"eld1\n", JNull), ("field2\x5", JString ""), 55 | ("field3", JObject $ M.singleton "subField" (JArray [])) ] 56 | -------------------------------------------------------------------------------- /week4/json-print/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Map (Map) 2 | import Data.List (intercalate) 3 | import qualified Data.Map as M 4 | import Numeric (showHex) 5 | 6 | data JSON = JNull | JNum Double | JString String | JArray [JSON] | JObj (Map String JSON) | JBool Bool 7 | 8 | escapeUnicode :: Char -> String 9 | escapeUnicode c = "\\u" ++ replicate (4 - length h) '0' ++ h 10 | where 11 | h = showHex (fromEnum c) "" 12 | 13 | escape :: String -> String 14 | escape s = "\"" ++ concatMap escapeChar s ++ "\"" 15 | where 16 | escapeChar '"' = "\\\"" 17 | escapeChar '\\' = "\\\\" 18 | escapeChar '\b' = "\\b" 19 | escapeChar '\f' = "\\f" 20 | escapeChar '\n' = "\\n" 21 | escapeChar '\r' = "\\r" 22 | escapeChar '\t' = "\\t" 23 | escapeChar x | x < '\x20' = escapeUnicode x 24 | escapeChar x = [x] 25 | 26 | instance Show JSON where 27 | show JNull = "null" 28 | show (JBool b) = if b then "true" else "false" 29 | show (JNum x) = show x 30 | show (JString s) = escape s 31 | show (JArray objs) = "[" ++ intercalate "," (map show objs) ++ "]" 32 | show (JObj m) = "{" ++ intercalate "," (elems m) ++ "}" 33 | where 34 | elems x = 35 | map (\(key,value) -> (escape key ++ ":" ++ show value)) (M.toList x) 36 | 37 | main :: IO () 38 | main = do 39 | print JNull 40 | print $ JBool True 41 | print $ JNum 10.123 42 | print $ JString "hello" 43 | print $ JArray [JNull, JBool False, JArray []] 44 | print $ JObj M.empty 45 | print $ JObj $ M.fromList [("field1", JNull), ("field2", JString "A \" quote!"), 46 | ("field3", JObj $ M.singleton "subField" (JArray []))] 47 | -- putStrLn "A new\nline!" 48 | print $ JString "A new\nline!" 49 | -------------------------------------------------------------------------------- /week4/justify/int-index/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase, TypeApplications, OverloadedStrings, BangPatterns #-} 2 | 3 | module Main where 4 | 5 | import Data.Text as Text 6 | import Data.Text.IO as Text 7 | import Text.Read (readMaybe) 8 | import Data.List as List 9 | import Data.List.NonEmpty as NonEmpty 10 | import Data.Semigroup 11 | import Data.Maybe 12 | import Data.Bool 13 | import Data.Ratio 14 | import System.Exit 15 | 16 | data Line = Line 17 | { lineWidth :: Int 18 | , lineWords :: NonEmpty Text } 19 | 20 | initLine :: Text -> Line 21 | initLine w = Line (Text.length w) (w :| []) 22 | 23 | appendLine :: Line -> Line -> Line 24 | appendLine line1 line2 = 25 | Line 26 | (lineWidth line1 + 1 + lineWidth line2) 27 | (lineWords line1 <> lineWords line2) 28 | 29 | nonEmptyTails :: NonEmpty a -> NonEmpty [a] 30 | nonEmptyTails = NonEmpty.fromList . List.tail . List.tails . NonEmpty.toList 31 | 32 | justify :: Int -> Text -> Text 33 | justify desiredLineWidth = 34 | Text.unlines . mergeLines . groupWords . List.map initLine . Text.words 35 | where 36 | groupWords :: [Line] -> [Line] 37 | groupWords = List.unfoldr (fmap @Maybe groupWords' . nonEmpty) 38 | 39 | groupWords' :: NonEmpty Line -> (Line, [Line]) 40 | groupWords' lines = 41 | fromMaybe (NonEmpty.head groupings) $ 42 | NonEmpty.last <$> nonEmpty goodGroupings 43 | where 44 | goodGroupings = NonEmpty.takeWhile (fits . fst) groupings 45 | groupings = 46 | NonEmpty.zip 47 | (NonEmpty.scanl1 appendLine lines) 48 | (nonEmptyTails lines) 49 | 50 | fits :: Line -> Bool 51 | fits line = lineWidth line <= desiredLineWidth 52 | 53 | mergeLines :: [Line] -> [Text] 54 | mergeLines [] = [] 55 | mergeLines [line] = [(Text.unwords . NonEmpty.toList . lineWords) line] 56 | mergeLines (line : lines) = mergeLine line : mergeLines lines 57 | 58 | mergeLine :: Line -> Text 59 | mergeLine line = 60 | concatSpaces 61 | (NonEmpty.toList (lineWords line)) 62 | (distributeExcessSpaces 63 | (NonEmpty.length (lineWords line) - 1) 64 | (desiredLineWidth - lineWidth line)) 65 | 66 | concatSpaces :: [Text] -> [Int] -> Text 67 | concatSpaces ts [] = Text.unwords ts 68 | concatSpaces (t:ts) (s:ss) = 69 | t <> Text.replicate (s + 1) " " <> concatSpaces ts ss 70 | 71 | distributeExcessSpaces 72 | :: Int -- position count 73 | -> Int -- excess space count 74 | -> [Int] -- space by positions 75 | distributeExcessSpaces positions n = List.take positions (distrib freq) 76 | where 77 | freq = n % positions 78 | distrib !prob = 79 | let k = floor prob :: Int 80 | in k : distrib (prob + freq - fromIntegral k) 81 | 82 | main :: IO () 83 | main = do 84 | width <- do 85 | s <- Text.getLine 86 | case readMaybe @Int (Text.unpack s) of 87 | Just n | n >= 0 -> return n 88 | _ -> do 89 | Text.putStrLn "Not a valid width." 90 | exitFailure 91 | line <- Text.getLine 92 | Text.putStrLn (justify width line) 93 | -------------------------------------------------------------------------------- /week4/justify/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Function (on) 4 | import Data.List 5 | 6 | -- | distribute words in lines greedily 7 | -- | note: this is not the best way 8 | -- | best way would be to use dynamic programming 9 | greedyLines :: Int -> String -> [[String]] 10 | greedyLines n str = result where 11 | result = if null lln 12 | then reverse lns 13 | else reverse $ reverse lln : lns 14 | 15 | -- | The accumulator is a triple where 16 | -- | the first component is the return value, 17 | -- | the second component is the "current line" which at the end of the fold 18 | -- | is also the "last line". The third component is the length of the 19 | -- | current line. 20 | -- | To make it faster, (:) is used instead of (++), 21 | -- | but then we need to use reverse too (which in the end is still faster). 22 | (lns, lln, _) = foldl' f ([], [], 0) (words str) 23 | f (ls, [], 0) w = (ls, [w], length w) 24 | f (ls, cs, k) w 25 | | n + 1 < l = ([w] : reverse cs : ls, [], 0) 26 | | n + 1 < nk = (reverse cs : ls, [w], l) 27 | | otherwise = (ls, w : cs, nk) 28 | where 29 | l = 1 + length w 30 | nk = k + l 31 | 32 | -- | put in necessary spaces to justify one line 33 | justifyLine :: Int -> [String] -> [String] 34 | justifyLine n ws = map addSpaces (zip ws [0..]) 35 | where 36 | -- | number of words 37 | nw = length ws 38 | -- | number of spaces 39 | np = nw - 1 40 | -- | length of the words 41 | lws = map length ws 42 | -- | number of characters in the line 43 | nc = sum lws 44 | -- | number of spaces to add in for justification 45 | ac = n - nc 46 | -- | number of spaces to distribute equally, 47 | -- | number of spaces to fit in best way 48 | (ec, dc) = divMod ac np 49 | -- | ideal length 50 | ideal = fromIntegral nc / fromIntegral (dc+1) 51 | -- | places where to put the best to fit spaces 52 | ps = snd $ dP dc 0 lws 53 | 54 | -- | fill in the spaces 55 | addSpaces (w, i) = w ++ replicate nsp ' ' where 56 | nsp 57 | | i == nw - 1 = 0 58 | | i `elem` ps = ec+1 59 | | otherwise = ec 60 | 61 | -- | places where to add the best fitted spaces 62 | -- | by dynamic programming 63 | dP 64 | :: Int -- how many left to fit 65 | -> Int -- which initial word is the first in our subtext 66 | -> [Int] -- the lengths of the words in our subtext 67 | -> (Double, [Int]) -- (badness of our choices, choices of the places) 68 | dP 0 _ ls = (0, []) 69 | dP k iw ls = minimumBy (compare `on` fst) choices where 70 | m = length ls 71 | l = sum ls 72 | choices = map f [0..m-k-1] 73 | f i = (badness + rb, (i+iw):rs) where 74 | (rb, rs) = dP (k-1) (i+iw+1) $ drop (i+1) ls 75 | segl = fromIntegral $ sum $ take (i+1) ls -- length of the cut 76 | badness = (segl - ideal) ^ 2 77 | 78 | -- | justify text 79 | justify :: Int -> String -> String 80 | justify n str = intercalate "\n" $ map concat jlns where 81 | lns = greedyLines n str 82 | jlns = map (justifyLine n) (init lns) ++ [map (++" ") $ last lns] 83 | 84 | main :: IO () 85 | main = do 86 | width <- read <$> getLine 87 | text <- getLine 88 | putStrLn "" 89 | putStrLn $ justify width text 90 | -------------------------------------------------------------------------------- /week4/path/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TupleSections #-} 2 | 3 | import Data.Array 4 | import Data.List 5 | import qualified Data.Map as M 6 | import Data.Map (Map) 7 | import Data.Monoid 8 | 9 | main = solve (mkArray2d test) 10 | 11 | mkArray2d :: [[a]] -> Array (Int, Int) a 12 | mkArray2d xs = listArray ((0,0),(height-1,width-1)) (concat xs) 13 | where 14 | width = length (last xs) 15 | height = length xs 16 | 17 | showArray2d :: Array (Int, Int) Char -> String 18 | showArray2d a = unlines [[a ! (y,x) | x <- [xmin..xmax]] | y <- [ymin..ymax]] 19 | where 20 | ((ymin, xmin), (ymax, xmax)) = bounds a 21 | 22 | solve :: Array Pos Char -> IO () 23 | solve field = do 24 | let Just aPos = fmap fst $ find ((== 'A') . snd) $ assocs field 25 | Just bPos = fmap fst $ find ((== 'B') . snd) $ assocs field 26 | let mbPath = floodfill 27 | (fmap (== '#') field) -- obstacle map 28 | bPos -- cell to find 29 | mempty -- already visited 30 | (M.singleton aPos aPos) -- frontier; we pretend that we 31 | -- came to A from itself 32 | putStrLn (showArray2d field) 33 | case mbPath of 34 | Nothing -> putStrLn "path not found" 35 | Just path -> putStrLn $ showArray2d $ 36 | field // map (,'+') (init (tail path)) 37 | 38 | test = 39 | [ "A.........#.....#...." 40 | , "...####...#.....#...." 41 | , "...#........#####...." 42 | , "...#..#.....#.......#" 43 | , "...####.##......#...." 44 | , "#.......#............" 45 | , "...#........#.....#.." 46 | , "......#.............." 47 | , "...#.......#B..#....." 48 | , ".....#..####........." 49 | , "#..........###......." ] 50 | 51 | type Pos = (Int, Int) 52 | 53 | {- | 54 | Here's how the floodfill algorithm works. We have this matrix: 55 | 56 | A#.. 57 | .... 58 | .... 59 | 60 | Initially only the A cell is at the frontier. We mark it with ?. 61 | 62 | ?#.. 63 | .... 64 | .... 65 | 66 | Now we mark the frontier cells as visited and mark all unvisited cells around them as “frontier”: 67 | 68 | 0#.. 69 | ?... 70 | .... 71 | 72 | And so it goes, advancing the frontier, until all cells are visited (or rather, until there are no cells at the frontier): 73 | 74 | 0 1 2 3 4 5 end 75 | 76 | ?#.. 0#.. 0#.. 0#.. 0#?. 0#4? 0#45 77 | .... ?... 1?.. 12?. 123? 1234 1234 78 | .... .... ?... 2?.. 23?. 234? 2345 79 | 80 | After it's done, we need to trace our path back to the original cell, so for each visited cell we also store the cell from where we came from. 81 | -} 82 | floodfill 83 | :: Array Pos Bool -- ^ Obstacle map; 'True' = obstacle 84 | -> Pos -- ^ Cell we want to find 85 | -> Map Pos Pos -- ^ Already visited cells, together with “from what 86 | -- cell did we come to this cell?” 87 | -> Map Pos Pos -- ^ Cells at the “frontier” 88 | -> Maybe [Pos] -- ^ Resulting path (reversed) 89 | floodfill field goal visited frontier 90 | -- If the cell is at the frontier, we can reconstruct the path to it. 91 | | goal `M.member` frontier = Just (findPath goal visited') 92 | -- If the frontier is empty and we haven't found the cell before that, the 93 | -- cell is unreachable. 94 | | null frontier = Nothing 95 | -- If the frontier isn't empty but also doesn't contain the cell, we 96 | -- advance the frontier and keep going. 97 | | otherwise = floodfill field goal visited' frontier' 98 | where 99 | visited' = visited <> frontier 100 | neighbors (y,x) = [(y-1,x),(y,x-1),(y+1,x),(y,x+1)] 101 | frontier' = M.fromList [(neighbor, cell) 102 | | cell <- M.keys frontier 103 | , neighbor <- neighbors cell 104 | , inRange (bounds field) neighbor 105 | , field ! neighbor == False 106 | , neighbor `M.notMember` visited' ] 107 | 108 | findPath :: Pos -> Map Pos Pos -> [Pos] 109 | findPath cell m 110 | | cell == prev = [cell] 111 | | otherwise = cell : findPath prev m 112 | where 113 | prev = m M.! cell 114 | -------------------------------------------------------------------------------- /week4/path/thalesmg/sample1: -------------------------------------------------------------------------------- 1 | A.........#.....#.... 2 | ...####...#.....#.... 3 | ...#........#####.... 4 | ...#..#.....#.......# 5 | ...####.##......#.... 6 | #.......#............ 7 | ...#........#.....#.. 8 | ......#.............. 9 | ...#.......#B..#..... 10 | .....#..####......... 11 | #..........###....... 12 | -------------------------------------------------------------------------------- /week4/path/thalesmg/sample2: -------------------------------------------------------------------------------- 1 | A.........#.....#.... 2 | ...####...#.....#.... 3 | ...#........#####.... 4 | ...#..#.....#.......# 5 | ...####.##......#.... 6 | #.......#............ 7 | ...#........#.....#.. 8 | ......#....#.#....... 9 | ...#.......#B#.#..... 10 | .....#..####.#....... 11 | #............#....... 12 | -------------------------------------------------------------------------------- /week4/path/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | module Main where 3 | 4 | import Control.Monad 5 | import Data.Array 6 | import Data.List 7 | import Data.List.Split 8 | import Data.Map (Map) 9 | import qualified Data.Map as M 10 | import Data.Maybe 11 | import Data.Set (Set) 12 | import qualified Data.Set as S 13 | 14 | type Index = (Int, Int) 15 | 16 | data Infinite a = Finite a | Infinity deriving (Show, Eq, Ord) 17 | 18 | data ProblemState = ProblemState 19 | { dist :: Array Index (Infinite Int) 20 | , edges :: Array Index Char 21 | , unvisited :: Set (Infinite Int, Index) 22 | , prev :: Map Index Index } deriving (Show) 23 | 24 | blockerCh = '#' 25 | startCh = 'A' 26 | endCh = 'B' 27 | 28 | add :: Num a => Infinite a -> Infinite a -> Infinite a 29 | add Infinity _ = Infinity 30 | add _ Infinity = Infinity 31 | add (Finite a) (Finite b) = Finite $ a+b 32 | 33 | initialize :: [String] -> (Int, Index, Index, ProblemState) 34 | initialize [] = undefined 35 | initialize ss@(s:_) = (n, start, end, ProblemState {..}) where 36 | m = length ss 37 | n = length s 38 | input = concat ss 39 | bnds = ((0, 0), (m-1,n-1)) 40 | edges = listArray bnds input 41 | start = divMod (fromMaybe 0 $ elemIndex startCh input) n 42 | end = divMod (fromMaybe 0 $ elemIndex endCh input) n 43 | unvisited = S.singleton (Finite 0, start) 44 | dist = listArray bnds (repeat Infinity) // [(start, Finite 0)] 45 | prev = M.empty 46 | 47 | neighbours :: Array Index Char -> Index -> [Index] 48 | neighbours eds (r,c) = do 49 | (i, j) <- [(r-1, c), (r+1, c), (r, c-1), (r, c+1)] 50 | let bnds = bounds eds 51 | guard ( inRange bnds (i,j) && eds ! (i,j) /= blockerCh) 52 | return (i, j) 53 | 54 | 55 | -- | Nothing = we can go on searching 56 | -- | Just False = there's no path 57 | -- | Just True = the path was found 58 | go :: ProblemState -> (Maybe Bool, ProblemState) 59 | go pst@ProblemState{..} 60 | | null unvisited = (Just False, pst) 61 | | otherwise = (found, newstate) 62 | where 63 | ((cd, ci), moretovisit) = S.deleteFindMin unvisited 64 | nbs = neighbours edges ci 65 | d = add (Finite 1) cd 66 | upds = [i | i <- nbs, dist ! i > d] 67 | 68 | found 69 | | cd == Infinity = Just False 70 | | endCh == edges ! ci = Just True 71 | | otherwise = Nothing 72 | 73 | newstate = ProblemState 74 | { dist = dist // zip upds (repeat d) 75 | , edges = edges // [(ci, blockerCh)] 76 | , unvisited = S.union moretovisit (S.fromList $ zip (repeat d) upds) 77 | , prev = M.union prev (M.fromList $ zip upds (repeat ci)) } 78 | 79 | tracePath :: (Index, Index) -> Map Index Index -> [Index] 80 | tracePath (start, end) prevs = if M.null prevs then [] else ps where 81 | ps = reverse $ helper (prevs M.! end) [] 82 | helper i acc 83 | | i == start = acc 84 | | otherwise = i : helper (prevs M.! i) acc 85 | 86 | findPath :: (Maybe Bool, ProblemState) -> Map Index Index 87 | findPath (Nothing, st) = findPath $ go st 88 | findPath (Just False, st) = M.empty 89 | findPath (Just True, st) = prev st 90 | 91 | test = 92 | [ "A.........#.....#...." 93 | , "...####...#.....#...." 94 | , "...#........#####...." 95 | , "...#..#.....#.......#" 96 | , "...####.##......#...." 97 | , "#.......#............" 98 | , "...#........#.....#.." 99 | , "......#.............." 100 | , "...#.......#B..#....." 101 | , ".....#..####........." 102 | , "#..........###......." ] 103 | 104 | test2 = 105 | [ "A.." 106 | , ".##" 107 | , ".#B" ] 108 | 109 | main :: IO () 110 | main = do 111 | contents <- getContents 112 | putStrLn contents 113 | putStrLn "\n" 114 | let (ncols, start, end, initialState) = initialize $ lines contents 115 | path = tracePath (start, end) $ findPath (Nothing, initialState) 116 | board = edges initialState 117 | if null path 118 | then putStrLn "There's no path." 119 | else putStrLn . unlines . chunksOf ncols . elems $ board // zip path (repeat '+') 120 | -------------------------------------------------------------------------------- /week4/spiral/aneksteind/spiral.hs: -------------------------------------------------------------------------------- 1 | module Spiral where 2 | 3 | import Data.Matrix 4 | 5 | data Direction = R | D | U | L 6 | 7 | main :: IO () 8 | main = do 9 | putStrLn "Please enter a size for the spiral!" 10 | i <- getInt 11 | putStrLn $ concatMap (\line -> (concatMap (\x -> if x == 1 then "* " else " ") line) ++ "\n") $ toLists $ spiral i 12 | 13 | spiral :: Int -> Matrix Int 14 | spiral i = buildSpiral (zero i i) i R (1,1) 0 15 | 16 | buildSpiral :: Matrix Int -> Int -> Direction -> (Int, Int) -> Int -> Matrix Int 17 | buildSpiral m i dir curr count | count >=3 = (setElem 1 curr m) 18 | | (available m curr) = 19 | if (atBound dir curr i m) 20 | then buildSpiral m i (nextDir dir) curr (count + 1) 21 | else buildSpiral (setElem 1 curr m) i dir (nextPos dir curr) 0 22 | | otherwise = m 23 | 24 | available :: Matrix Int -> (Int, Int) -> Bool 25 | available m pos = (m ! pos) \= 1 26 | 27 | atBound :: Direction -> (Int,Int) -> Int -> Matrix Int -> Bool 28 | atBound R c@(x,y) i m = (atEnd i R c) || ((distToEnd i R c) > 1 && m ! (x,y+2) == 1) 29 | atBound D c@(x,y) i m = (atEnd i D c) || ((distToEnd i D c) > 1 && m ! (x+2,y) == 1) 30 | atBound L c@(x,y) i m = (atEnd i L c) || ((distToEnd i L c) > 1 && m ! (x,y-2) == 1) 31 | atBound U c@(x,y) i m = (atEnd i U c) || ((distToEnd i U c) > 1 && m ! (x-2,y) == 1) 32 | 33 | atEnd :: Int -> Direction -> (Int,Int) -> Bool 34 | atEnd i R (x,y) = i - y == 0 35 | atEnd i D (x,y) = i - x == 0 36 | atEnd _ L (x,y) = y == 1 37 | atEnd _ U (x,y) = x == 1 38 | 39 | distToEnd :: Int -> Direction -> (Int,Int) -> Int 40 | distToEnd i R (x,y) = i - y 41 | distToEnd i D (x,y) = i - x 42 | distToEnd _ L (x,y) = y - 1 43 | distToEnd _ U (x,y) = x - 1 44 | 45 | nextPos :: Direction -> (Int,Int) -> (Int,Int) 46 | nextPos R (x,y) = (x,y+1) 47 | nextPos D (x,y) = (x+1,y) 48 | nextPos L (x,y) = (x,y-1) 49 | nextPos U (x,y) = (x-1,y) 50 | 51 | nextDir :: Direction -> Direction 52 | nextDir R = D 53 | nextDir D = L 54 | nextDir U = R 55 | nextDir L = U 56 | 57 | getInt :: IO Int 58 | getInt = do 59 | str <- getLine 60 | return (read str) -------------------------------------------------------------------------------- /week4/spiral/balac/Main.hs: -------------------------------------------------------------------------------- 1 | import System.IO 2 | import Data.Array 3 | 4 | data Dir = DOWN | LEFT | UP | RIGHT 5 | deriving( Show, Ord, Eq, Enum ) 6 | 7 | move :: (Int,Int) -> Dir -> (Int,Int) 8 | move (x,y) d = case d of 9 | DOWN -> (x, y+1) 10 | LEFT -> (x-1, y) 11 | UP -> (x, y-1) 12 | RIGHT-> (x+1,y) 13 | 14 | spiralDirs :: Int -> [Dir] 15 | spiralDirs width = concatMap (\(num, dir) -> replicate num dir ) $ ( width-1, RIGHT ) : zip ( reverse [1..width] ) ( cycle [ DOWN .. RIGHT ] ) 16 | 17 | spiralIndices :: Int -> [(Int,Int)] 18 | spiralIndices width = scanl move (1,1) $ spiralDirs width 19 | 20 | showSpiral :: Array (Int,Int) Char -> String 21 | showSpiral spiral = unlines rows 22 | where 23 | (width,height) = snd $ bounds spiral 24 | rows = map (\row -> [ spiral ! ( col, row ) | col <- [ 1 .. width ] ] ) [ 1 .. height ] 25 | 26 | main :: IO () 27 | main = do 28 | hSetEncoding stdout utf8 29 | hSetBuffering stdout NoBuffering 30 | putStr "Size? " 31 | width <- read <$> getLine 32 | let indices = spiralIndices width 33 | arr = listArray ( (1,1), (width, width+1) ) ( repeat ' ' ) 34 | spiral = arr // [ ( ind, '*' ) | ind <- indices ] 35 | putStrLn $ showSpiral spiral -------------------------------------------------------------------------------- /week4/spiral/jasonkuhrt/spiral.cabal: -------------------------------------------------------------------------------- 1 | name: spiral 2 | version: 0.1.0.0 3 | category: App 4 | build-type: Simple 5 | -- extra-source-files: 6 | cabal-version: >=1.10 7 | 8 | library 9 | hs-source-dirs: . 10 | exposed-modules: Main 11 | build-depends: base >= 4.7 && < 5, matrix 12 | default-language: Haskell2010 13 | 14 | source-repository head 15 | type: git 16 | location: https://github.com/jasonkuhrt/spiral 17 | -------------------------------------------------------------------------------- /week4/spiral/jasonkuhrt/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 | # http://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-7.0 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.1" 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 -------------------------------------------------------------------------------- /week4/spiral/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Foldable (for_) 2 | 3 | {- 4 | Take a spiral with e.g. size 9 and look at the empty space inside: 5 | 6 | ********* 7 | * xxxxxxxx 8 | ******* * x 9 | * * * xxxxx x 10 | * *** * * x x x 11 | * * * * * x x x x 12 | * * * * x xxx x 13 | * ***** * x x 14 | * * xxxxxxx 15 | ********* 16 | 17 | Apart from the extra space in the beginning, it's a spiral with size 7. 18 | -} 19 | 20 | inSpiral :: Int -> (Int, Int) -> Bool 21 | inSpiral n (x,y) = or [ 22 | -- First line, last line, and last column are always filled 23 | y == 0, y == n, x == n-1, 24 | -- Only one element in the first column isn't filled 25 | x == 0 && y /= 1, 26 | -- Otherwise, the filled elements are ones that wouldn't be filled in a 27 | -- smaller spiral 28 | not (inSpiral (n-2) (x-1, y-1)) ] 29 | 30 | main = do 31 | putStr "Size? " 32 | n <- readLn 33 | for_ [0..n] $ \y -> do 34 | for_ [0..n-1] $ \x -> 35 | putChar (if inSpiral n (x,y) then '*' else ' ') 36 | putStrLn "" 37 | -------------------------------------------------------------------------------- /week4/spiral/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.List 4 | import Data.Set (Set) 5 | import qualified Data.Set as S 6 | 7 | -- | Returns the graph set of the spiral, 8 | -- | i.e the points that are on the spiral. 9 | spiralGraph :: Int -> Set (Int, Int) 10 | spiralGraph n = fst $ foldl' f (S.empty, (0,-1)) $ zip counts deltas 11 | -- | The start is outside the grid ^^^^ 12 | -- | We'll step into (0,0) right away. 13 | where 14 | -- | Counts are basically the lengths of the lines of the spiral 15 | -- | Here's the pattern: (n: pattern) 16 | -- | 9: 9 9 8 7 6 5 4 3 2 1 17 | -- | 8: 8 8 7 6 5 4 3 2 1 18 | -- | etc 19 | counts = n : [n, n-1..1] 20 | -- | Go right, down, left, up and then cycle that. 21 | deltas = cycle [(0,1), (1, 0), (0, -1), (-1, 0)] 22 | -- | So zip counts deltas is like: 23 | -- | go 9 times right, 8 times down, 8 times left, 6 times up, etc 24 | -- | Put the visited points into the Graph set. 25 | 26 | -- | Helper function that add two pairs 27 | add (a, b) (c, d) = (a+c, b+d) 28 | -- | The fold function that carries current position along with the Graph. 29 | f (set, current) (count, delta) = foldl' g (set, current) [1..count] where 30 | g (s, c) _ = let next = add c delta in (S.insert next s, next) 31 | 32 | -- | "Draw" the spiral Graph. 33 | spiral :: Int -> String 34 | spiral n = concatMap enfold $ zip line [1..] where 35 | line = map f [(i,j) | i <- [0..n], j <- [0..n-1]] 36 | graph = spiralGraph n 37 | f c = if S.member c graph then '*' else ' ' 38 | enfold (ch, p) = [ch, if mod p n == 0 then '\n' else ' '] 39 | 40 | main :: IO () 41 | main = do 42 | putStr "Size? " 43 | n <- read <$> getLine 44 | putStrLn "" 45 | putStrLn $ spiral n 46 | -------------------------------------------------------------------------------- /week4/trie/stites/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE InstanceSigs #-} 2 | -------------------------------------------------------------------------------- 3 | -- 18. Trie /{trie}/ 4 | -- 5 | -- Construct a trie from all words in a dictionary and implement search for 6 | -- words by prefix. Here's an example of a trie for 7 | -- /{cool, cat, coal, bet, bean}/: 8 | -- 9 | -- b c 10 | -- / / \ 11 | -- e a o 12 | -- / \ / / \ 13 | -- t a t a o 14 | -- | | | 15 | -- n l l 16 | -- 17 | -- You should read the words file, construct a trie, say how many nodes are in 18 | -- the trie (e.g. in the sample one there are 13 nodes), and then answer user's 19 | -- queries to find all words starting with given letters: 20 | -- 21 | -- Trie created. There are 13 nodes. 22 | -- 23 | -- > be 24 | -- bean bet 25 | -- 26 | -- > c 27 | -- cat coal cool 28 | -- 29 | -- > co 30 | -- coal cool 31 | -- 32 | -- You can use the following type for the trie (but feel free to use something 33 | -- else): 34 | -- 35 | -- data Trie a = Empty | Node (Map a (Trie a)) 36 | -- 37 | -- The list of words in available in the /data\// folder in the repository. 38 | -------------------------------------------------------------------------------- 39 | module Main where 40 | 41 | import Control.Monad (forever) 42 | import Data.Monoid 43 | import Data.List 44 | import Data.Maybe 45 | import Data.Map.Strict (Map) 46 | import qualified Data.Map.Strict as M 47 | 48 | filepath :: FilePath 49 | filepath = "data/words" 50 | 51 | main :: IO () 52 | main = do 53 | contents <- readFile filepath 54 | let t = fromFileContents contents :: Trie Char 55 | putStrLn $ "Trie created. There are " ++ show (size t) ++ " nodes." 56 | forever $ do 57 | putStr "> " 58 | query <- getLine 59 | putStrLn . renderQueryResults . queryTrie t $ query 60 | return () 61 | 62 | where 63 | -- assume that the words on a file are each on separate lines 64 | fromFileContents :: String -> Trie Char 65 | fromFileContents = foldl' mappend mempty . fmap fromList . lines 66 | 67 | queryTrie :: Trie Char -> String -> Maybe [String] 68 | queryTrie t query = fmap (fmap (query ++) . toList) . subTrie t $ query 69 | 70 | renderQueryResults :: Maybe [String] -> String 71 | renderQueryResults = unwords . fromMaybe [""] 72 | 73 | 74 | ------------------------------------------------------------------------ 75 | -- Declare a Trie and useful typeclasses 76 | 77 | data Trie a 78 | = Empty 79 | | Node (Map a (Trie a)) 80 | deriving (Show) 81 | 82 | instance Ord a => Monoid (Trie a) where 83 | mempty :: Trie a 84 | mempty = Empty 85 | 86 | mappend :: Trie a -> Trie a -> Trie a 87 | mappend Empty t = t 88 | mappend t Empty = t 89 | mappend (Node t0) (Node t1) = Node $ M.unionWith mappend t0 t1 90 | 91 | -- A Trie can be constructed from a list 92 | fromList :: Ord a => [a] -> Trie a 93 | fromList [] = Empty 94 | fromList (a:as) = Node . M.singleton a . fromList $ as 95 | 96 | -- A Trie can be deconstructed to a list of lists 97 | toList :: Trie a -> [[a]] 98 | toList Empty = [[]] 99 | toList (Node m) = concat . M.elems . M.mapWithKey go $ m 100 | where 101 | go :: a -> Trie a -> [[a]] 102 | go k = fmap (k:) . toList 103 | 104 | -- get the number of nodes in the trie 105 | size :: Trie a -> Int 106 | size Empty = 0 107 | size (Node m) = M.size m + sum (M.map size m) 108 | 109 | -- return a sub tree at some point of traversal 110 | subTrie :: Ord a => Trie a -> [a] -> Maybe (Trie a) 111 | subTrie Empty as = Nothing 112 | subTrie m [] = Just m 113 | subTrie (Node m) (a:as) = M.lookup a m >>= (`subTrie` as) 114 | 115 | 116 | -------------------------------------------------------------------------------- /week4/trie/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import qualified Data.Map.Lazy as M 2 | import Control.Monad (forever) 3 | import Data.Map.Lazy (Map) 4 | 5 | data Trie a = Empty | Node Bool (Map a (Trie a)) deriving (Show) 6 | 7 | singletonTrie :: [a] -> Bool -> Trie a 8 | singletonTrie [] _ = Empty 9 | singletonTrie [c] b = Node b (M.singleton c Empty) 10 | singletonTrie (c:cs) b = Node b (M.singleton c (singletonTrie cs False)) 11 | 12 | addToTrie :: (Ord a) => Trie a -> [a] -> Trie a 13 | addToTrie t [] = t 14 | addToTrie Empty xs = singletonTrie xs False 15 | addToTrie (Node bool mp) (x:xs) = 16 | case M.lookup x mp of 17 | Nothing -> Node bool (M.insert x (singletonTrie xs False) mp) 18 | Just Empty -> Node bool (M.insert x (singletonTrie xs True) mp) 19 | Just t' -> Node bool (M.insert x (addToTrie t' xs) mp) 20 | 21 | countNodes :: Trie a -> Int 22 | countNodes t = 23 | let 24 | count' Empty acc = acc 25 | count' (Node _ mp) acc = M.foldr count' (acc + M.size mp) mp 26 | in 27 | count' t 0 28 | 29 | -- Shorter, cleaner version 30 | countNodes2 :: Trie a -> Int 31 | countNodes2 Empty = 0 32 | countNodes2 (Node _ mp) = M.size mp + sum(M.map countNodes2 mp) 33 | 34 | queryTrie :: (Ord a) => Trie a -> [a] -> [[a]] 35 | queryTrie Empty _ = [[]] 36 | queryTrie (Node bool mp) [] = 37 | if bool then [] : ws else ws 38 | where 39 | ws = do 40 | c <- M.keys mp 41 | let t = mp M.! c 42 | rest <- queryTrie t [] 43 | return $ c:rest 44 | queryTrie (Node _ mp) (x:xs) = case M.lookup x mp of 45 | Nothing -> [] 46 | Just t -> do 47 | rest <- queryTrie t xs 48 | return (x : rest) 49 | 50 | main :: IO () 51 | main = do 52 | ws <- lines <$> readFile "../../../data/words" 53 | let trie = foldl addToTrie Empty ws 54 | putStrLn $ "Trie created. There are " ++ show (countNodes2 trie) ++ " nodes." 55 | forever $ do 56 | query <- getLine 57 | putStrLn . unwords $ queryTrie trie query 58 | -------------------------------------------------------------------------------- /week5/README.md: -------------------------------------------------------------------------------- 1 | ## Week 5 (October 3 – October 9) 2 | 3 | This week has only got two tasks, because experimenting with format is fun. One task is tricky and the other one is hard. 4 | 5 | ### 21. Write a quine `{quine}` 6 | 7 | A quine is a program that prints its own source code. 8 | 9 | Write a quine in Haskell. (Tricks like reading your own source with `readFile` aren't allowed.) 10 | 11 | ### 22. Write a database engine `{db}` 12 | 13 | This is what you should be able to do with your database: 14 | 15 | * Create a table: 16 | 17 | ``` 18 | > CREATE TABLE foo (id UNIQUE NOT NULL, name, age NOT NULL) 19 | ``` 20 | 21 | This command creates an empty table called `foo` with three columns – guaranteedly unique `id` which must not be `NULL`, arbitrary `name`, and `age` which must again not be `NULL`. (When any of the constraints is violated, the command which violated the constraint should fail.) 22 | 23 | * Insert a record into the table: 24 | 25 | ``` 26 | > INSERT INTO foo VALUES (13, 'Tom', 26) 27 | ``` 28 | 29 | If the table doesn't exist, or the number of columns doesn't match, or any of the constraints are violated, the command should fail. 30 | 31 | * Delete records from the table: 32 | 33 | ``` 34 | > DELETE FROM foo WHERE name = 'Tom' 35 | > DELETE FROM foo WHERE age < 18 OR age > 65 36 | ``` 37 | 38 | * Select records from the table: 39 | 40 | ``` 41 | > SELECT * FROM foo WHERE name = 'Tom' 42 | 1. id = 13, name = 'Tom', age = 26 43 | 2. id = 30, name = 'Tom', age = 52 44 | 45 | > SELECT name, age FROM foo WHERE name = 'Tom' 46 | 1. name = 'Tom', age = 26 47 | 2. name = 'Tom', age = 52 48 | ``` 49 | 50 | That's all. 51 | 52 | Note that you don't actually need to implement a parser for queries! I wrote them in SQL so that it would be easier to understand what they do (if you know SQL). For **level one,** you only need to implement commands (e.g. `insert :: ... -> Db -> Either DbError Db`), tests (with `hspec`), and a benchmark suite (with `criterion`). The database will be in-memory. 53 | 54 | I would suggest something like `data Value = Null | Number Scientific | String Text | ...` for storing values. Note that data in columns doesn't have to be type safe – it's entirely possible to insert a row with `age = 'foo'`. Also note that you would have to implement an extra type for expressions (such as `age = 3`). Something like `type Predicate = Value -> Bool` would work, but it would make implementing next levels harder. 55 | 56 | For **level two,** you need to implement a parser for queries – I suggest `megaparsec`. You also need to implement serialisation for the database, and commands to save and load a database to/from a file. (With `binary` or `cereal` you can do that pretty much automatically.) 57 | 58 | For **level three,** implement any of the following: 59 | 60 | * Add indices to make queries on specific columns faster. (Don't forget to benchmark.) 61 | 62 | * Add `JOIN`. 63 | 64 | * Add foreign keys. 65 | 66 | * Allow optional type constraints on columns. Use them to report more errors, as well as to store data more efficiently. 67 | 68 | And finally, keep in mind that having implemented this task is more important than having done it “all by yourself” – so ask questions, Google, and don't hesitate to steal others' ideas if they're good. 69 | -------------------------------------------------------------------------------- /week5/quine/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.Char 2 | import Data.List 3 | main = do 4 | let bracket arr = putStr ( intercalate [chr 34] arr ) >> putStrLn ( show arr ) >> putStr " bracket codeArray" 5 | let codeArray = ["import Data.Char\nimport Data.List\nmain = do\n let bracket arr = putStr ( intercalate [chr 34] arr ) >> putStrLn ( show arr ) >> putStr "," bracket codeArray","\n let codeArray = "] 6 | bracket codeArray -------------------------------------------------------------------------------- /week5/quine/jasonkuhrt/Main.hs: -------------------------------------------------------------------------------- 1 | main = putStr (code ++ show code) 2 | code = "main = putStr (code ++ show code)\ncode = " 3 | -------------------------------------------------------------------------------- /week5/quine/neongreen/Main.hs: -------------------------------------------------------------------------------- 1 | main = putStrLn $ (++) <*> show $ "main = putStrLn $ (++) <*> show $ " 2 | -------------------------------------------------------------------------------- /week5/quine/thalesmg/Main.hs: -------------------------------------------------------------------------------- 1 | import Data.List (intercalate) 2 | 3 | main :: IO () 4 | main = do 5 | let q = toEnum 34 :: Char 6 | let c = toEnum 44 :: Char 7 | let ob = toEnum 91 :: Char 8 | let cb = toEnum 93 :: Char 9 | let txt = ["import Data.List (intercalate)","","main :: IO ()","main = do"," let q = toEnum 34 :: Char"," let c = toEnum 44 :: Char"," let ob = toEnum 91 :: Char"," let cb = toEnum 93 :: Char"," let txt = "," mapM_ putStrLn $ take 8 txt"," putStrLn $ concat [txt !! 8, [ob], [q], intercalate [q,c,q] (take 9 txt ++ drop 9 txt), [q], [cb]]"," mapM_ putStrLn $ drop 9 txt"] 10 | mapM_ putStrLn $ take 8 txt 11 | putStrLn $ concat [txt !! 8, [ob], [q], intercalate [q,c,q] (take 9 txt ++ drop 9 txt), [q], [cb]] 12 | mapM_ putStrLn $ drop 9 txt 13 | -------------------------------------------------------------------------------- /week5/quine/vitcra/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | sp1 = (" " ++) 4 | sp2 = (" , " ++) 5 | h = 7 6 | 7 | self = [ 8 | "module Main where" 9 | , "" 10 | , "sp1 = (\" \" ++)" 11 | , "sp2 = (\" , \" ++)" 12 | , "h = 7" 13 | , "" 14 | , "self = [" 15 | , " ]" 16 | , "" 17 | , "main :: IO ()" 18 | , "main = do" 19 | , " mapM_ putStrLn (take h self)" 20 | , " putStrLn $ sp1 . show $ head self" 21 | , " mapM_ (putStrLn . sp2 . show) $ tail self" 22 | , " mapM_ putStrLn (drop h self)" 23 | ] 24 | 25 | main :: IO () 26 | main = do 27 | mapM_ putStrLn (take h self) 28 | putStrLn $ sp1 . show $ head self 29 | mapM_ (putStrLn . sp2 . show) $ tail self 30 | mapM_ putStrLn (drop h self) 31 | -------------------------------------------------------------------------------- /week6/README.md: -------------------------------------------------------------------------------- 1 | ## Week 6 (October 11 – October 16) 2 | 3 | ### 23. Write QuickCheck `{quickcheck}` 4 | 5 | You need to write a function called `check` that would generate arbitrary testcases, pass them to a property, and print the first testcase for which the property has failed: 6 | 7 | ```haskell 8 | allNumbersDivideEachOther :: (Int, Int) -> Bool 9 | allNumbersDivideEachOther (a, b) = a `mod` b == 0 10 | ``` 11 | 12 | ```haskell 13 | > check allNumbersDivideEachOther 14 | False! Testcase: (5,3) 15 | ``` 16 | 17 | You'll need to write your own class (e.g. `Arbitrary`) for generating random testcases for various types. 18 | 19 | Once you have an initial implementation, here are ideas on how to improve it: 20 | 21 | * Count exceptions as test failures too. 22 | 23 | * Add shrinking of testcases by adding a function called `shrink` to the typeclass, which would attempt to generate “smaller” testcases from a testcase. (For instance, it might decrease the number for `Int`, or remove some elements from `[Bool]`.) Testcases like `(3,2)` are usually nicer to investigate than `(13426634,234623)`. 24 | 25 | * Handle functions with several parameters (in the same `check` function). You'll need to write another typeclass for that, `Testable`. 26 | 27 | ### 24. Choosing a serialization method `{serialize}` 28 | 29 | Let's say you've got a huge `Tree` (from `Data.Tree`) and you want to write it to a file. To do that, you first serialize it (i.e. convert to a `ByteString`). There are lots of ways to do that – you can `show` it and then convert the result to UTF-8, you can convert it to JSON with Aeson, you can use `binary` or `cereal` (or even `binary-serialise-cbor`), MessagePack, etc. Which of those is the fastest? Investigate by benchmarking various methods with [criterion](https://hackage.haskell.org/package/criterion). (It can generate nice HTML reports and you're advised to look at them – but also do include text results in comments.) You can benchmark deserialization as well, but it's not mandatory. Of course, it might turn out that different libraries are better for different trees – if your benchmarks discover that, it would be even better. 30 | 31 | (Don't forget that performance-critical code should be compiled with `-O2`. Also, don't accidentally benchmark writing into the file itself.) 32 | --------------------------------------------------------------------------------