├── src ├── .ghci ├── Course │ ├── .ghci │ ├── JsonValue.hs │ ├── FastAnagrams.hs │ ├── Person.hs │ ├── ExactlyOne.hs │ ├── Anagrams.hs │ ├── Compose.hs │ ├── Comonad.hs │ ├── Core.hs │ ├── Extend.hs │ ├── Optional.hs │ ├── Validation.hs │ ├── Functor.hs │ ├── FileIO.hs │ ├── Traversable.hs │ ├── Monad.hs │ ├── Alternative.hs │ └── Interactive.hs └── Course.hs ├── share ├── a.txt ├── b.txt ├── c.txt └── files.txt ├── cabal.project ├── Setup.lhs ├── projects ├── NetworkServer │ └── haskell │ │ ├── .ghci │ │ ├── test │ │ ├── .gitignore │ │ └── doctests.hs │ │ ├── src │ │ ├── Network │ │ │ ├── Server.hs │ │ │ └── Server │ │ │ │ ├── TicTacToe │ │ │ │ ├── Main.hs │ │ │ │ ├── Game.hs │ │ │ │ └── Loop.hs │ │ │ │ ├── Chat │ │ │ │ ├── Main.hs │ │ │ │ ├── Chat.hs │ │ │ │ └── Loop.hs │ │ │ │ ├── Chat.hs │ │ │ │ ├── TicTacToe.hs │ │ │ │ ├── Common │ │ │ │ ├── Ref.hs │ │ │ │ ├── HandleLens.hs │ │ │ │ ├── Accept.hs │ │ │ │ ├── Env.hs │ │ │ │ ├── Line.hs │ │ │ │ └── Lens.hs │ │ │ │ └── Common.hs │ │ └── Data │ │ │ └── TicTacToe.hs │ │ ├── .gitignore │ │ ├── etc │ │ └── LICENCE │ │ ├── Setup.lhs │ │ └── network-server.cabal └── TicTacToe │ ├── haskell │ ├── test │ │ ├── .gitignore │ │ └── doctests.hs │ ├── changelog │ ├── .ghci │ ├── .gitignore │ ├── src │ │ ├── TicTacToe.hs │ │ └── TicTacToe │ │ │ ├── AsWin.hs │ │ │ ├── Winpaths.hs │ │ │ ├── Draw.hs │ │ │ ├── AsOccupied.hs │ │ │ ├── AsOr.hs │ │ │ ├── Player.hs │ │ │ ├── Back.hs │ │ │ ├── OccupiedOr.hs │ │ │ ├── WinOccupiedOr.hs │ │ │ ├── WithPosition.hs │ │ │ ├── Position.hs │ │ │ └── Console.hs │ ├── LICENSE │ ├── Setup.lhs │ └── tictactoe.cabal │ ├── java │ └── src │ │ └── tictactoe │ │ ├── Player.java │ │ ├── TakenBack.java │ │ ├── Position.java │ │ ├── GameResult.java │ │ ├── BoardLike.java │ │ ├── MoveResult.java │ │ ├── Board.java │ │ └── Main.java │ ├── agda │ └── TicTacToe.agda │ └── TicTacToe.markdown ├── test ├── .gitignore ├── Course │ ├── ComonadTest.hs │ ├── OptionalTest.hs │ ├── FunctorTest.hs │ ├── ExtendTest.hs │ ├── MonadTest.hs │ ├── ValidationTest.hs │ ├── Gens.hs │ ├── ChequeTest.hs │ ├── StateTest.hs │ ├── TraversableTest.hs │ └── JsonParserTest.hs └── TastyLoader.hs ├── .editorconfig ├── shell.nix ├── Vagrantfile ├── .ghci ├── changelog ├── course.lkshf ├── .gitignore ├── fp-course.nix ├── ci ├── jobsets.json ├── ci.nix └── jobsets.nix ├── ops ├── sublime.yaml ├── vs-code.yaml ├── haskell.yaml ├── emacs.d │ └── init.el ├── README.md └── ansible.yaml ├── default.nix ├── etc ├── LICENCE └── CONTRIBUTORS ├── course.cabal └── .travis.yml /src/.ghci: -------------------------------------------------------------------------------- 1 | Course/.ghci -------------------------------------------------------------------------------- /share/a.txt: -------------------------------------------------------------------------------- 1 | the contents of a 2 | -------------------------------------------------------------------------------- /share/b.txt: -------------------------------------------------------------------------------- 1 | the contents of b 2 | -------------------------------------------------------------------------------- /share/c.txt: -------------------------------------------------------------------------------- 1 | the contents of c 2 | -------------------------------------------------------------------------------- /cabal.project: -------------------------------------------------------------------------------- 1 | packages: 2 | ./ 3 | -------------------------------------------------------------------------------- /share/files.txt: -------------------------------------------------------------------------------- 1 | share/a.txt 2 | share/b.txt 3 | share/c.txt 4 | -------------------------------------------------------------------------------- /Setup.lhs: -------------------------------------------------------------------------------- 1 | \begin{code} 2 | import Distribution.Simple 3 | main = defaultMain 4 | \end{code} 5 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :l src/Network/Server.hs 3 | :set prompt ">> " 4 | :set -Wall 5 | -------------------------------------------------------------------------------- /test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/test/.gitignore: -------------------------------------------------------------------------------- 1 | # cabal 2 | /dist 3 | 4 | # cabal-dev 5 | /cabal-dev 6 | 7 | # Haskell Program Coverage 8 | /.hpc 9 | -------------------------------------------------------------------------------- /.editorconfig: -------------------------------------------------------------------------------- 1 | [*] 2 | end_of_line = lf 3 | insert_final_newline = true 4 | charset = utf-8 5 | 6 | [*.{hs,yaml}] 7 | indent_style = space 8 | indent_size = 2 9 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/changelog: -------------------------------------------------------------------------------- 1 | 0.0.1 2 | 3 | * Initial version 4 | 5 | 0.1.0 6 | 7 | * Solution now uses lens 8 | * Enforces more invariants 9 | 10 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server.hs: -------------------------------------------------------------------------------- 1 | module Network.Server 2 | ( 3 | module Network.Server.Common 4 | ) where 5 | 6 | import Network.Server.Common 7 | 8 | -------------------------------------------------------------------------------- /src/Course/.ghci: -------------------------------------------------------------------------------- 1 | :! echo -e "\033[0;31m\033[47mYOU ARE IN THE WRONG DIRECTORY\033[0m" 2 | :set prompt "\ESC[1;40m\STX%s\n\ESC[0;41m\STXYOU ARE IN THE WRONG DIRECTORY> \ESC[m\STX" 3 | kill -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -idist/build/autogen 2 | :set -optP-include -optPdist/build/autogen/cabal_macros.h 3 | :load src/TicTacToe/Console.hs 4 | :set prompt ">> " 5 | :set -Wall 6 | 7 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe/Main.hs: -------------------------------------------------------------------------------- 1 | module Main 2 | ( 3 | main 4 | ) where 5 | 6 | import Network.Server.TicTacToe.Game 7 | 8 | main :: 9 | IO () 10 | main = 11 | play 12 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat/Main.hs: -------------------------------------------------------------------------------- 1 | module Main ( 2 | main 3 | ) where 4 | 5 | import Network.Server.Chat.Chat 6 | import Network.Server.Chat.Loop 7 | 8 | main :: 9 | IO a 10 | main = 11 | chat 12 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat 2 | ( 3 | module Network.Server.Chat.Chat 4 | , module Network.Server.Chat.Loop 5 | ) where 6 | 7 | import Network.Server.Chat.Chat 8 | import Network.Server.Chat.Loop 9 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe 2 | ( 3 | module Network.Server.TicTacToe.Game 4 | , module Network.Server.TicTacToe.Loop 5 | ) where 6 | 7 | import Network.Server.TicTacToe.Game 8 | import Network.Server.TicTacToe.Loop 9 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | /dist 6 | /.cabal-sandbox 7 | /cabal.sandbox.config 8 | 9 | # Haskell Program Coverage 10 | /.hpc 11 | /*.tix 12 | 13 | # Leksah 14 | *.lkshs 15 | 16 | # Intellij IDEA 17 | /.idea 18 | *.iml 19 | 20 | # ctags 21 | TAGS 22 | 23 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default"}: 2 | let 3 | inherit (nixpkgs) pkgs; 4 | drv = import ./default.nix { inherit nixpkgs compiler; }; 5 | drvWithTools = pkgs.haskell.lib.addBuildDepends drv [ pkgs.cabal-install ]; 6 | in 7 | if pkgs.lib.inNixShell then drvWithTools.env else drvWithTools 8 | -------------------------------------------------------------------------------- /Vagrantfile: -------------------------------------------------------------------------------- 1 | Vagrant.configure("2") do |config| 2 | config.vm.box = "ubuntu/xenial64" 3 | 4 | config.vm.provider 'virtualbox' do |vbox| 5 | vbox.memory = 4096 6 | vbox.cpus = 2 7 | vbox.gui = true 8 | end 9 | 10 | config.vm.provision 'ansible' do |ansible| 11 | ansible.playbook = 'ops/ansible.yaml' 12 | end 13 | end 14 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | dist 6 | 7 | # cabal-dev 8 | /cabal-dev 9 | 10 | # Haskell Program Coverage 11 | .hpc 12 | 13 | # Leksah 14 | *.lkshs 15 | 16 | # Intellij IDEA 17 | .idea/workspace.xml 18 | .idea/ant.xml 19 | 20 | # darcs 21 | _darcs 22 | 23 | # ctags 24 | TAGS 25 | 26 | # sbt 27 | /project 28 | /target 29 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -itest 3 | :l src/Course.hs 4 | :set prompt ">> " 5 | :set -Wall 6 | :set -fno-warn-unused-binds 7 | :set -fno-warn-unused-do-bind 8 | :set -fno-warn-unused-imports 9 | :set -fno-warn-type-defaults 10 | :set -XNoImplicitPrelude 11 | :set -XScopedTypeVariables 12 | :set -XOverloadedStrings 13 | :set -XRebindableSyntax 14 | :set -XTypeApplications 15 | -------------------------------------------------------------------------------- /changelog: -------------------------------------------------------------------------------- 1 | 0.1.1 2 | 3 | This change log started. 4 | 5 | 0.1.2 6 | 7 | Switch around the the hex parser exercise. There are now two exercises: 8 | 9 | 1. Implement `hex`, which is a sub-exercise of the previous `hex`. 10 | 2. Implement `hexu`, which is the complete exercise of what was formerly `hex`. 11 | 12 | This switching is required to implement `jsonString` parser properly (without a try-parser). 13 | 14 | -------------------------------------------------------------------------------- /course.lkshf: -------------------------------------------------------------------------------- 1 | { 2 | "configFlags": [ 3 | "--enable-tests" 4 | ], 5 | "benchmarkFlags": [], 6 | "sdistFlags": [], 7 | "registerFlags": [], 8 | "installFlags": [], 9 | "exeFlags": [], 10 | "unregisterFlags": [], 11 | "haddockFlags": [], 12 | "testFlags": [ 13 | "--doctest-options=-package=QuickCheck", 14 | "--doctest-options=-package=template-haskell" 15 | ], 16 | "buildFlags": [] 17 | } -------------------------------------------------------------------------------- /src/Course/JsonValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.JsonValue where 5 | 6 | import Course.Core 7 | import Course.List 8 | 9 | type Assoc = List (Chars, JsonValue) 10 | 11 | data JsonValue = 12 | JsonString Chars 13 | | JsonRational Rational 14 | | JsonObject Assoc 15 | | JsonArray (List JsonValue) 16 | | JsonTrue 17 | | JsonFalse 18 | | JsonNull 19 | deriving (Show, Eq) 20 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *#* 3 | 4 | # CABAL 5 | dist 6 | dist-newstyle 7 | cabal-dev 8 | .cabal-sandbox 9 | cabal.sandbox.config 10 | cabal.project.local 11 | .ghc.environment.* 12 | 13 | # Haskell Program Coverage 14 | /.hpc 15 | 16 | # Leksah 17 | *.lkshs 18 | 19 | # Intellij IDEA 20 | /.idea 21 | 22 | # darcs 23 | /_darcs 24 | 25 | # ctags 26 | TAGS 27 | 28 | # sbt 29 | /project 30 | /target 31 | 32 | *.swp 33 | 34 | # Stack 35 | .stack-work/ 36 | 37 | # Vagrant 38 | .vagrant 39 | ops/*.retry 40 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Ref.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Ref where 2 | 3 | import Network.Server.Common.HandleLens(HandleLens(..)) 4 | import Network.Server.Common.Lens(iso) 5 | import System.IO(Handle) 6 | import Data.Function(on) 7 | 8 | newtype Ref = 9 | Ref Handle 10 | deriving (Eq, Show) 11 | 12 | instance Ord Ref where 13 | compare = 14 | compare `on` show 15 | 16 | instance HandleLens Ref where 17 | handleL = 18 | iso (\(Ref h) -> h) Ref 19 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe.hs: -------------------------------------------------------------------------------- 1 | module TicTacToe( 2 | module T 3 | ) where 4 | 5 | import TicTacToe.AsOccupied as T 6 | import TicTacToe.AsOr as T 7 | import TicTacToe.AsWin as T 8 | import TicTacToe.Back as T 9 | import TicTacToe.Draw as T 10 | import TicTacToe.Move as T 11 | import TicTacToe.MoveOr as T 12 | import TicTacToe.Player as T 13 | import TicTacToe.Position as T 14 | import TicTacToe.OccupiedOr as T 15 | import TicTacToe.WinOccupiedOr as T 16 | import TicTacToe.Winpaths as T 17 | import TicTacToe.WithPosition as T 18 | -------------------------------------------------------------------------------- /fp-course.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, array, base, containers, HUnit, QuickCheck, stdenv 2 | , tasty, tasty-hunit, tasty-quickcheck, doctest 3 | }: 4 | mkDerivation { 5 | pname = "course"; 6 | version = "0.1.4"; 7 | src = ./.; 8 | libraryHaskellDepends = [ array base containers ]; 9 | testHaskellDepends = [ 10 | base HUnit QuickCheck tasty tasty-hunit tasty-quickcheck doctest 11 | ]; 12 | homepage = "https://github.com/data61/fp-course"; 13 | description = "Source code for a functional programming course"; 14 | license = stdenv.lib.licenses.bsd3; 15 | } 16 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common 2 | ( 3 | module Network.Server.Common.Accept 4 | , module Network.Server.Common.Env 5 | , module Network.Server.Common.HandleLens 6 | , module Network.Server.Common.Lens 7 | , module Network.Server.Common.Line 8 | , module Network.Server.Common.Ref 9 | ) where 10 | 11 | import Network.Server.Common.Accept 12 | import Network.Server.Common.Env 13 | import Network.Server.Common.HandleLens 14 | import Network.Server.Common.Lens 15 | import Network.Server.Common.Line 16 | import Network.Server.Common.Ref 17 | -------------------------------------------------------------------------------- /ci/jobsets.json: -------------------------------------------------------------------------------- 1 | { 2 | "enabled": 1, 3 | "hidden": false, 4 | "description": "jobsets", 5 | "nixexprinput": "fp-course", 6 | "nixexprpath": "ci/jobsets.nix", 7 | "checkinterval": 300, 8 | "schedulingshares": 1, 9 | "enableemail": false, 10 | "emailoverride": "", 11 | "keepnr": 5, 12 | "inputs": { 13 | "fp-course": { "type": "git", "value": "https://github.com/data61/fp-course.git master", "emailresponsible": false }, 14 | "nixpkgs": { "type": "git", "value": "https://github.com/NixOS/nixpkgs.git release-18.09", "emailresponsible": false } 15 | } 16 | } 17 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/Player.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | 5 | public enum Player { 6 | Player1, Player2; 7 | 8 | public Player alternate() { 9 | return this == Player1 ? Player2 : Player1; 10 | } 11 | 12 | public char toSymbol() { 13 | return this == Player1 ? 'X' : 'O'; 14 | } 15 | 16 | @Override 17 | public String toString() { 18 | return this == Player1 ? "Player 1" : "Player 2"; 19 | } 20 | 21 | public static final F toSymbol = new F() { 22 | public Character f(final Player p) { 23 | return p.toSymbol(); 24 | } 25 | }; 26 | } 27 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/AsWin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | module TicTacToe.AsWin( 7 | AsWin(_Win) 8 | ) where 9 | 10 | import Control.Applicative(Applicative) 11 | import Control.Lens(Optic, Choice, _1, _Left) 12 | import Data.Either(Either) 13 | import Data.Functor(Functor) 14 | 15 | class AsWin p f o where 16 | _Win :: 17 | Optic p f (o w a) (o x a) w x 18 | 19 | instance (Choice p, Applicative f) => AsWin p f Either where 20 | _Win = 21 | _Left 22 | 23 | instance (p ~ (->), Functor f) => AsWin p f (,) where 24 | _Win = 25 | _1 26 | -------------------------------------------------------------------------------- /ops/sublime.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Check if Sublime installed" 3 | command: which subl 4 | ignore_errors: true 5 | register: haz_sublime 6 | 7 | - name: "Add apt key for sublime" 8 | apt_key: 9 | url: https://download.sublimetext.com/sublimehq-pub.gpg 10 | state: present 11 | become: yes 12 | when: haz_sublime|failed 13 | 14 | - name: "Add source for sublime" 15 | apt_repository: 16 | repo: deb https://download.sublimetext.com/ apt/stable/ 17 | state: present 18 | become: yes 19 | when: haz_sublime|failed 20 | 21 | - name: "Install sublime" 22 | apt: 23 | name: sublime-text 24 | update_cache: yes 25 | state: present 26 | become: yes 27 | when: haz_sublime|failed 28 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/TakenBack.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | import fj.P1; 5 | 6 | public abstract class TakenBack { 7 | private TakenBack() {} 8 | 9 | public abstract X fold(P1 isEmpty, F isBoard); 10 | 11 | public static TakenBack isEmpty() { 12 | return new TakenBack() { 13 | public X fold(final P1 isEmpty, final F isBoard) { 14 | return isEmpty._1(); 15 | } 16 | }; 17 | } 18 | 19 | public static TakenBack isBoard(final Board b) { 20 | return new TakenBack() { 21 | public X fold(final P1 isEmpty, final F isBoard) { 22 | return isBoard.f(b); 23 | } 24 | }; 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Winpaths.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | 3 | module TicTacToe.Winpaths( 4 | Winpaths(winpaths) 5 | , hasWin 6 | ) where 7 | 8 | import Control.Category((.)) 9 | import Control.Lens((#)) 10 | import Data.Bool(Bool) 11 | import Data.Eq((==)) 12 | import Data.Foldable(any, sum) 13 | import Data.Functor(fmap) 14 | import Data.Int(Int) 15 | import TicTacToe.Position(Position, _Position, magic) 16 | 17 | class Winpaths w where 18 | winpaths :: 19 | w 20 | -> [(Position, Position)] 21 | 22 | hasWin :: 23 | Winpaths w => 24 | Position 25 | -> w 26 | -> Bool 27 | hasWin p m = 28 | any (\(p2, p3) -> sum (fmap (_Position . magic #) [p, p2, p3]) == (15 :: Int)) (winpaths m) 29 | -------------------------------------------------------------------------------- /test/Course/ComonadTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.ComonadTest where 5 | 6 | 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?=)) 9 | 10 | import Course.Comonad (copure, (<$$>)) 11 | import Course.Core 12 | import Course.ExactlyOne (ExactlyOne (..)) 13 | 14 | test_Comonad :: TestTree 15 | test_Comonad = 16 | testGroup "Comonad" [ 17 | exactlyOneTest 18 | , fmapTest 19 | ] 20 | 21 | exactlyOneTest :: TestTree 22 | exactlyOneTest = 23 | testCase "ExactlyOne" $ copure (ExactlyOne 7) @?= 7 24 | 25 | fmapTest :: TestTree 26 | fmapTest = 27 | testCase "<$$>" $ 28 | ((+10) <$$> ExactlyOne 7) @?= ExactlyOne 17 29 | -------------------------------------------------------------------------------- /src/Course/FastAnagrams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.FastAnagrams where 5 | 6 | import Course.Core 7 | import Course.List 8 | import Course.Functor 9 | import qualified Data.Set as S 10 | 11 | -- Return all anagrams of the given string 12 | -- that appear in the given dictionary file. 13 | fastAnagrams :: 14 | Chars 15 | -> FilePath 16 | -> IO (List Chars) 17 | fastAnagrams name f = 18 | (flip (filter . flip S.member) (permutations name) . S.fromList . hlist . lines) <$> readFile f 19 | 20 | newtype NoCaseString = 21 | NoCaseString { 22 | ncString :: Chars 23 | } 24 | 25 | instance Eq NoCaseString where 26 | (==) = (==) `on` map toLower . ncString 27 | 28 | instance Show NoCaseString where 29 | show = show . ncString 30 | -------------------------------------------------------------------------------- /ops/vs-code.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Check if VS Code is installed" 3 | command: which code 4 | ignore_errors: true 5 | register: haz_code 6 | 7 | - name: "Download VS code" 8 | get_url: 9 | url: https://go.microsoft.com/fwlink/?LinkID=760868 10 | dest: /tmp/vs-code.deb 11 | when: haz_code|failed 12 | 13 | # So the recommended install method is to install a thing with broken/missing 14 | # dependencies, and then fix it. 15 | - name: "Install VS Code deb" 16 | command: dpkg -i /tmp/vs-code.deb 17 | become: yes 18 | ignore_errors: true 19 | when: haz_code|failed 20 | 21 | - name: "Fix VS code installation" 22 | command: apt-get install -fy 23 | become: yes 24 | when: haz_code|failed 25 | 26 | - name: "Install haskell syntax highlighting for VS Code" 27 | command: code --install-extension justusadam.language-haskell 28 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Draw.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | 7 | module TicTacToe.Draw( 8 | Draw(isDraw) 9 | ) where 10 | 11 | import Control.Category 12 | import Control.Lens.Extras(is) 13 | import Data.Bool(Bool) 14 | import Prelude() 15 | import TicTacToe.AsOr(AsOr(_Or)) 16 | import TicTacToe.Move(Win9, Move9) 17 | import TicTacToe.MoveOr(Move9Or(Move9Or)) 18 | import TicTacToe.WinOccupiedOr(WinOccupiedOr) 19 | 20 | class Draw g where 21 | isDraw :: 22 | g 23 | -> Bool 24 | 25 | instance Draw (WinOccupiedOr Win9 Move9) where 26 | isDraw = 27 | is _Or 28 | 29 | instance Draw Move9Or where 30 | isDraw (Move9Or m) = 31 | isDraw m 32 | 33 | instance Draw Bool where 34 | isDraw = 35 | id 36 | -------------------------------------------------------------------------------- /ops/haskell.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | 3 | - name: Add ghc PPA 4 | apt_repository: 5 | repo: ppa:hvr/ghc 6 | become: yes 7 | 8 | - name: Install ghc-8.0.2 9 | apt: 10 | name: "{{ item }}" 11 | update_cache: yes 12 | state: present 13 | with_items: 14 | - ghc-8.0.2 15 | - cabal-install-1.24 16 | become: yes 17 | 18 | - name: Add cabal bin directory to PATH 19 | lineinfile: 20 | line: export PATH="{{ ansible_env.HOME }}/.cabal/bin:$PATH" 21 | dest: ~/.profile 22 | 23 | - name: Add /opt/ghc/bin to the path 24 | lineinfile: 25 | line: export PATH=/opt/ghc/bin:$PATH 26 | dest: ~/.profile 27 | 28 | - name: Update cabal 29 | command: cabal update 30 | environment: 31 | PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" 32 | 33 | - name: Insall cabal packages 34 | command: cabal install doctest 35 | environment: 36 | PATH: "/opt/ghc/bin:{{ ansible_env.PATH }}" 37 | -------------------------------------------------------------------------------- /src/Course/Person.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Person where 5 | 6 | import Course.Core 7 | import Course.List 8 | 9 | -- Suppose we have a data structure to represent a person. The person data structure has these attributes: 10 | -- * Age: positive integer 11 | -- * First Name: non-empty string that starts with a capital letter and is followed by zero or more lower-case letters 12 | -- * Surname: string that starts with a capital letter and is followed by 5 or more lower-case letters 13 | -- * Smoker: character that must be 'y' or 'n' that maps to a boolean 14 | -- * Phone: string of digits, dots or hyphens but must start with a digit and end with a hash (#) 15 | data Person = 16 | Person 17 | Int -- age 18 | Chars -- first name 19 | Chars -- surname 20 | Bool -- smoker 21 | Chars -- phone number 22 | deriving (Eq, Show) 23 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/HandleLens.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.HandleLens where 2 | 3 | import Network.Server.Common.Lens(Lens, identityL, getL) 4 | import System.IO(Handle, BufferMode, hGetLine, hPutStrLn, hClose, hSetBuffering) 5 | 6 | class HandleLens a where 7 | handleL :: 8 | Lens a Handle 9 | 10 | instance HandleLens Handle where 11 | handleL = 12 | identityL 13 | 14 | lGetLine :: 15 | HandleLens h => 16 | h 17 | -> IO String 18 | lGetLine h = 19 | hGetLine (handleL `getL` h) 20 | 21 | lPutStrLn :: 22 | HandleLens h => 23 | h 24 | -> String 25 | -> IO () 26 | lPutStrLn h = 27 | hPutStrLn (handleL `getL` h) 28 | 29 | lClose :: 30 | HandleLens h => 31 | h 32 | -> IO () 33 | lClose h = 34 | hClose (handleL `getL` h) 35 | 36 | lSetBuffering :: 37 | HandleLens h => 38 | h 39 | -> BufferMode 40 | -> IO () 41 | lSetBuffering h = 42 | hSetBuffering (handleL `getL` h) 43 | -------------------------------------------------------------------------------- /ci/ci.nix: -------------------------------------------------------------------------------- 1 | { supportedSystems ? ["x86_64-linux"] 2 | , supportedCompilers ? [ "ghc802" "ghc822" "ghc843" ] 3 | }: 4 | 5 | with (import { inherit supportedSystems; }); 6 | 7 | let 8 | pkgs = import {}; 9 | 10 | configurations = 11 | pkgs.lib.listToAttrs ( 12 | pkgs.lib.concatMap (compiler: 13 | pkgs.lib.concatMap (system: 14 | [{name = "fp-course_" + compiler + "_" + system; value = {inherit compiler system;};}] 15 | ) supportedSystems 16 | ) supportedCompilers 17 | ); 18 | 19 | jobs = 20 | pkgs.lib.mapAttrs (name: configuration: 21 | let 22 | compiler = configuration.compiler; 23 | system = configuration.system; 24 | nixpkgs = { pkgs = pkgsFor system; }; 25 | course = import ../default.nix { inherit nixpkgs compiler; }; 26 | in 27 | course 28 | ) configurations; 29 | in 30 | jobs 31 | -------------------------------------------------------------------------------- /src/Course.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course (module X) where 5 | 6 | import Course.Anagrams as X 7 | import Course.Applicative as X 8 | import Course.Alternative as X 9 | import Course.Cheque as X 10 | import Course.Comonad as X (Comonad (..)) 11 | import Course.Compose as X 12 | import Course.Core as X 13 | import Course.ExactlyOne as X 14 | import Course.Extend as X 15 | import Course.FastAnagrams as X 16 | import Course.FileIO as X 17 | import Course.Functor as X 18 | import Course.Interactive as X 19 | import Course.JsonParser as X 20 | import Course.JsonValue as X 21 | import Course.List as X 22 | import Course.ListZipper as X 23 | import Course.Monad as X 24 | import Course.MoreParser as X 25 | import Course.Optional as X 26 | import Course.Parser as X 27 | import Course.Person as X 28 | import Course.State as X 29 | import Course.StateT as X 30 | import Course.Traversable as X 31 | import Course.Validation as X 32 | -------------------------------------------------------------------------------- /src/Course/ExactlyOne.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.ExactlyOne where 5 | 6 | import qualified Control.Applicative as A 7 | import qualified Control.Monad as M 8 | import Course.Core 9 | import qualified Prelude as P 10 | 11 | data ExactlyOne a = ExactlyOne a deriving (Eq, Show) 12 | 13 | runExactlyOne :: ExactlyOne a -> a 14 | runExactlyOne (ExactlyOne a) = a 15 | 16 | mapExactlyOne :: (a -> b) -> ExactlyOne a -> ExactlyOne b 17 | mapExactlyOne f (ExactlyOne a) = ExactlyOne (f a) 18 | 19 | bindExactlyOne :: (a -> ExactlyOne b) -> ExactlyOne a -> ExactlyOne b 20 | bindExactlyOne f (ExactlyOne a) = f a 21 | 22 | instance P.Functor ExactlyOne where 23 | fmap = 24 | M.liftM 25 | 26 | instance A.Applicative ExactlyOne where 27 | (<*>) = 28 | M.ap 29 | pure = 30 | ExactlyOne 31 | 32 | instance P.Monad ExactlyOne where 33 | (>>=) = 34 | flip bindExactlyOne 35 | return = 36 | ExactlyOne 37 | 38 | -------------------------------------------------------------------------------- /ci/jobsets.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs, declInput }: let pkgs = import nixpkgs {}; in { 2 | jobsets = pkgs.runCommand "spec.json" {} '' 3 | cat < $out < AsOccupied p f (Maybe a) where 27 | _Occupied = 28 | _Nothing 29 | 30 | instance (Choice p, Applicative f) => AsOccupied p f [a] where 31 | _Occupied = 32 | _Empty 33 | 34 | occupied :: 35 | AsOccupied Tagged Identity a => a 36 | occupied = 37 | _Occupied # () 38 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (deps) 4 | import Control.Applicative 5 | import Control.Monad 6 | import Data.List 7 | import System.Directory 8 | import System.FilePath 9 | import Test.DocTest 10 | 11 | main :: 12 | IO () 13 | main = 14 | getSources >>= \sources -> doctest $ 15 | "-isrc" 16 | : "-idist/build/autogen" 17 | : "-optP-include" 18 | : "-optPdist/build/autogen/cabal_macros.h" 19 | : "-hide-all-packages" 20 | : map ("-package="++) deps ++ sources 21 | 22 | getSources :: IO [FilePath] 23 | getSources = filter (isSuffixOf ".hs") <$> go "src" 24 | where 25 | go dir = do 26 | (dirs, files) <- getFilesAndDirectories dir 27 | (files ++) . concat <$> mapM go dirs 28 | 29 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 30 | getFilesAndDirectories dir = do 31 | c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir 32 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 33 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/AsOr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | module TicTacToe.AsOr( 7 | AsOr(_Or) 8 | ) where 9 | 10 | import Control.Applicative(Applicative) 11 | import Control.Lens(Optic, Profunctor, Choice, iso, _Right, _Just) 12 | import Data.Either(Either) 13 | import Data.Functor(Functor) 14 | import Data.Functor.Identity(Identity(runIdentity, Identity)) 15 | import Data.Maybe(Maybe) 16 | import Data.Traversable(traverse) 17 | 18 | class AsOr p f o where 19 | _Or :: 20 | Optic p f (o a) (o b) a b 21 | 22 | instance (Profunctor p, Functor f) => AsOr p f Identity where 23 | _Or = 24 | iso 25 | runIdentity 26 | Identity 27 | 28 | instance (Choice p, Applicative f) => AsOr p f Maybe where 29 | _Or = 30 | _Just 31 | 32 | instance (Choice p, Applicative f) => AsOr p f (Either t) where 33 | _Or = 34 | _Right 35 | 36 | instance (p ~ (->), Applicative f) => AsOr p f [] where 37 | _Or = 38 | traverse 39 | -------------------------------------------------------------------------------- /src/Course/Anagrams.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.Anagrams where 6 | 7 | import Course.Core 8 | import Course.List 9 | import Course.Functor 10 | 11 | {- 12 | 13 | Functions you will need 14 | -- 15 | * fmap :: (a -> b) -> IO a -> IO b 16 | * readFile :: FilePath -> IO Str 17 | * lines :: Str -> [Str] 18 | * permutations :: [a] -> [[a]] 19 | * intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] 20 | * toLower :: Char -> Char 21 | 22 | Functions that might help 23 | - 24 | * on :: (b -> b -> c) -> (a -> b) -> a -> a -> c 25 | 26 | -} 27 | 28 | 29 | -- Return all anagrams of the given string 30 | -- that appear in the given dictionary file. 31 | anagrams :: 32 | Chars 33 | -> FilePath 34 | -> IO (List Chars) 35 | anagrams name = 36 | (<$>) (intersectBy equalIgnoringCase (permutations name) . lines) . readFile 37 | 38 | -- Compare two strings for equality, ignoring case 39 | equalIgnoringCase :: 40 | Chars 41 | -> Chars 42 | -> Bool 43 | equalIgnoringCase = 44 | (==) `on` map toLower 45 | -------------------------------------------------------------------------------- /src/Course/Compose.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Compose where 5 | 6 | import Course.Core 7 | import Course.Functor 8 | import Course.Applicative 9 | import Course.Monad 10 | 11 | -- Exactly one of these exercises will not be possible to achieve. Determine which. 12 | 13 | newtype Compose f g a = 14 | Compose (f (g a)) deriving (Show, Eq) 15 | 16 | -- Implement a Functor instance for Compose 17 | instance (Functor f, Functor g) => 18 | Functor (Compose f g) where 19 | f <$> Compose g = 20 | Compose ((f <$>) <$> g) 21 | 22 | instance (Applicative f, Applicative g) => 23 | Applicative (Compose f g) where 24 | -- Implement the pure function for an Applicative instance for Compose 25 | pure = 26 | Compose . pure . pure 27 | -- Implement the (<*>) function for an Applicative instance for Compose 28 | Compose f <*> Compose a = 29 | Compose (lift2 (<*>) f a) 30 | 31 | instance (Monad f, Monad g) => 32 | Monad (Compose f g) where 33 | -- Implement the (=<<) function for a Monad instance for Compose 34 | (=<<) = 35 | error "impossible" 36 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Accept.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Accept where 2 | 3 | import Network.Server.Common.Lens 4 | import Network.Server.Common.HandleLens(HandleLens(..)) 5 | import Network.Server.Common.Ref(Ref(..)) 6 | import Network(HostName, Socket, PortNumber, accept) 7 | 8 | data Accept = 9 | Accept 10 | Ref 11 | HostName 12 | PortNumber 13 | deriving (Eq, Ord, Show) 14 | 15 | refL :: 16 | Lens Accept Ref 17 | refL = 18 | Lens 19 | (\(Accept _ nam num) hd -> Accept hd nam num) 20 | (\(Accept hd _ _) -> hd) 21 | 22 | hostNameL :: 23 | Lens Accept HostName 24 | hostNameL = 25 | Lens 26 | (\(Accept hd _ num) nam -> Accept hd nam num) 27 | (\(Accept _ nam _) -> nam) 28 | 29 | portNumberL :: 30 | Lens Accept PortNumber 31 | portNumberL = 32 | Lens 33 | (\(Accept hd nam _) num -> Accept hd nam num) 34 | (\(Accept _ _ num) -> num) 35 | 36 | instance HandleLens Accept where 37 | handleL = 38 | refL .@ handleL 39 | 40 | accept' :: 41 | Socket 42 | -> IO Accept 43 | accept' = 44 | fmap (\(hd, nam, num) -> Accept (Ref hd) nam num) . accept 45 | -------------------------------------------------------------------------------- /src/Course/Comonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Comonad where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.Extend 10 | 11 | -- | All instances of the `Comonad` type-class must satisfy two laws. These 12 | -- laws are not checked by the compiler. These laws are given as: 13 | -- 14 | -- * The law of left identity 15 | -- `∀x. copure <<= x ≅ x` 16 | -- 17 | -- * The law of right identity 18 | -- `∀f. copure . (f <<=) == f 19 | class Extend f => Comonad f where 20 | copure :: 21 | f a 22 | -> a 23 | 24 | -- | Implement the @Comonad@ instance for @ExactlyOne@. 25 | -- 26 | -- >>> copure (ExactlyOne 7) 27 | -- 7 28 | instance Comonad ExactlyOne where 29 | copure :: 30 | ExactlyOne a 31 | -> a 32 | copure (ExactlyOne a) = 33 | a 34 | 35 | -- | Witness that all things with (<<=) and copure also have (<$>). 36 | -- 37 | -- >>> (+10) <$$> ExactlyOne 7 38 | -- ExactlyOne 17 39 | (<$$>) :: 40 | Comonad f => 41 | (a -> b) 42 | -> f a 43 | -> f b 44 | f <$$> a = 45 | f . copure <<= a 46 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Env.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Env where 2 | 3 | import Network.Server.Common.Accept 4 | import Network.Server.Common.Ref 5 | import Network.Server.Common.HandleLens 6 | import Network.Server.Common.Lens 7 | import Data.IORef(IORef, atomicModifyIORef) 8 | import Data.Set(Set) 9 | 10 | data Env a = 11 | Env 12 | Accept 13 | (IORef (Set Ref)) 14 | a 15 | deriving Eq 16 | 17 | acceptL :: 18 | Lens (Env a) Accept 19 | acceptL = 20 | Lens 21 | (\(Env _ s a) x -> Env x s a) 22 | (\(Env x _ _) -> x) 23 | 24 | clientsL :: 25 | Lens (Env a) (IORef (Set Ref)) 26 | clientsL = 27 | Lens 28 | (\(Env x _ a) s -> Env x s a) 29 | (\(Env _ s _) -> s) 30 | 31 | envvalL :: 32 | Lens (Env a) a 33 | envvalL = 34 | Lens 35 | (\(Env x s _) a -> Env x s a) 36 | (\(Env _ _ a) -> a) 37 | 38 | instance HandleLens (Env a) where 39 | handleL = 40 | acceptL .@ handleL 41 | 42 | instance Functor Env where 43 | fmap f (Env x s a) = 44 | Env x s (f a) 45 | 46 | atomicModifyIORef_ :: 47 | IORef a 48 | -> (a -> a) 49 | -> IO a 50 | atomicModifyIORef_ r f = 51 | atomicModifyIORef r (\a -> (f a, a)) 52 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | 3 | let 4 | inherit (nixpkgs) pkgs; 5 | 6 | haskellPackages = if compiler == "default" 7 | then pkgs.haskellPackages 8 | else pkgs.haskell.packages.${compiler}; 9 | 10 | sources = { 11 | tasty = pkgs.fetchFromGitHub { 12 | owner = "feuerbach"; 13 | repo = "tasty"; 14 | rev = "core-1.1.0.1"; 15 | sha256 = "03fcc75l5mrn5dwh6xix5ggn0qkp8kj7gzamb6n2m42ir6j7x60l"; 16 | }; 17 | }; 18 | 19 | modifiedHaskellPackages = haskellPackages.override { 20 | overrides = self: super: { 21 | tasty = super.callCabal2nix "tasty" "${sources.tasty}/core" {}; 22 | tasty-hunit = super.callCabal2nix "tasty" "${sources.tasty}/hunit" {}; 23 | tasty-quickcheck = super.callCabal2nix "tasty" "${sources.tasty}/quickcheck" {}; 24 | }; 25 | }; 26 | 27 | fp-course = modifiedHaskellPackages.callPackage ./fp-course.nix {}; 28 | modified-fp-course = pkgs.haskell.lib.overrideCabal fp-course (drv: { 29 | # Dodgy fun times, make sure that 30 | # - the tests compile 31 | # - the tests failing doesn't cause the build to fail 32 | checkPhase = "true"; 33 | }); 34 | in 35 | modified-fp-course 36 | 37 | -------------------------------------------------------------------------------- /ops/emacs.d/init.el: -------------------------------------------------------------------------------- 1 | ;; Pull in Marmalade packages 2 | (require 'package) 3 | (add-to-list 'package-archives 4 | '("marmalade" . "http://marmalade-repo.org/packages/")) 5 | (add-to-list 'package-archives 6 | '("melpa" . "http://melpa.milkbox.net/packages/")) 7 | (package-initialize) 8 | 9 | ;; Ensure our preferred packages are all loaded in this install - taken from 10 | ;; http://batsov.com/articles/2012/02/19/package-management-in-emacs-the-good-the-bad-and-the-ugly/ 11 | (defvar my-packages 12 | '(markdown-mode 13 | auto-complete 14 | haskell-mode) 15 | "A list of packages to ensure are installed at launch.") 16 | 17 | (require 'cl) 18 | (defun my-packages-installed-p () 19 | (loop for p in my-packages 20 | when (not (package-installed-p p)) do (return nil) 21 | finally (return t))) 22 | 23 | (unless (my-packages-installed-p) 24 | ;; check for new packages (package versions) 25 | (message "%s" "Emacs is now refreshing its package database...") 26 | (package-refresh-contents) 27 | (message "%s" " done.") 28 | ;; install the missing packages 29 | (dolist (p my-packages) 30 | (when (not (package-installed-p p)) 31 | (package-install p)))) 32 | 33 | ;; Show column numbers in mode line 34 | (column-number-mode t) 35 | -------------------------------------------------------------------------------- /ops/README.md: -------------------------------------------------------------------------------- 1 | # Vagrant Box 2 | 3 | If you'd rather use a pre-configured haskell development environment, then these instructions will 4 | get you up and running in a VirtualBox virtual machine. The machine includes: 5 | 6 | - A Xubuntu desktop environment 7 | - GHC 8.0.2 installed 8 | - doctest 9 | - emacs with haskell-mode 10 | - vim 11 | - sublime 12 | - VS Code 13 | 14 | **NOTE**: The VM's default user is `ubuntu` and their password is `ubuntu` 15 | 16 | **WARNING**: Building the environment might take a while and download gigabytes of pacakges over the internet. 17 | 18 | ## Prerequisites 19 | 20 | - Install [VirtualBox](https://www.virtualbox.org/) 21 | - Install [Vagrant](https://www.vagrantup.com/) 22 | - Install [ansible](https://www.ansible.com/) 23 | 24 | ## Make it so 25 | 26 | The following will download a VM image of Ubuntu and then provision it to build a desktop 27 | environment for Haskell development. Once it's provisioned, reload the machine, which will log you 28 | straight into a graphical environment. 29 | 30 | ``` 31 | cd fp-course 32 | vagrant up 33 | # go have lunch - this could take a while 34 | vagrant reload 35 | ``` 36 | 37 | You should now see a virtual machine running Xubuntu. The course materials are checked out to 38 | `~/fp-course` and you should have all required binaries on your PATH. 39 | -------------------------------------------------------------------------------- /test/TastyLoader.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ImplicitPrelude #-} 2 | 3 | import Data.String (fromString) 4 | import Test.Tasty 5 | import Course.ApplicativeTest (test_Applicative) 6 | import Course.ComonadTest (test_Comonad) 7 | import Course.ExtendTest (test_Extend) 8 | import Course.FunctorTest (test_Functor) 9 | import Course.JsonParserTest (test_JsonParser) 10 | import Course.ChequeTest (test_Cheque) 11 | import Course.ListTest (test_List) 12 | import Course.ListZipperTest (test_ListZipper) 13 | import Course.MonadTest (test_Monad) 14 | import Course.MoreParserTest (test_MoreParser) 15 | import Course.OptionalTest (test_Optional) 16 | import Course.ParserTest (test_Parser) 17 | import Course.StateTest (test_State) 18 | import Course.StateTTest (test_StateT) 19 | import Course.TraversableTest (test_Traversable) 20 | import Course.ValidationTest (test_Validation) 21 | 22 | main :: IO () 23 | main = defaultMain tests 24 | 25 | tests :: TestTree 26 | tests = 27 | testGroup "Tests" [ 28 | test_Optional 29 | , test_List 30 | , test_Functor 31 | , test_Applicative 32 | , test_Monad 33 | , test_MoreParser 34 | , test_Parser 35 | , test_State 36 | , test_StateT 37 | , test_Validation 38 | , test_Extend 39 | , test_Comonad 40 | , test_Traversable 41 | , test_ListZipper 42 | , test_JsonParser 43 | , test_Cheque 44 | ] 45 | 46 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Build_doctests (deps) 4 | import Control.Applicative 5 | import Control.Monad 6 | import Data.List 7 | import System.Directory 8 | import System.FilePath 9 | import Test.DocTest 10 | 11 | main :: 12 | IO () 13 | main = 14 | getSources >>= \sources -> doctest $ 15 | "-isrc" 16 | : "-idist/build/autogen" 17 | : "-optP-include" 18 | : "-optPdist/build/autogen/cabal_macros.h" 19 | : "-hide-all-packages" 20 | : map ("-package="++) deps ++ sources 21 | 22 | sourceDirectories :: 23 | [FilePath] 24 | sourceDirectories = 25 | [ 26 | "src" 27 | , "test" "src" 28 | ] 29 | 30 | isSourceFile :: 31 | FilePath 32 | -> Bool 33 | isSourceFile p = 34 | and [takeFileName p /= "Setup.hs", isSuffixOf ".hs" p] 35 | 36 | getSources :: IO [FilePath] 37 | getSources = 38 | liftM (filter isSourceFile . concat) (mapM go sourceDirectories) 39 | where 40 | go dir = do 41 | (dirs, files) <- getFilesAndDirectories dir 42 | (files ++) . concat <$> mapM go dirs 43 | 44 | getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) 45 | getFilesAndDirectories dir = do 46 | c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir 47 | (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c 48 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/Position.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | import fj.data.List; 5 | import fj.data.Option; 6 | 7 | import static fj.data.List.list; 8 | import static fj.data.Option.none; 9 | import static fj.data.Option.some; 10 | 11 | public enum Position { 12 | NW, N, NE, W, C, E, SW, S, SE; 13 | 14 | public int toInt() { 15 | return ordinal() + 1; 16 | } 17 | 18 | public char toChar() { 19 | return (char)(toInt() + '0'); 20 | } 21 | 22 | public static List positions() { 23 | return list(NW, N, NE, W, C, E, SW, S, SE); 24 | } 25 | 26 | public static Option fromInt(final int n) { 27 | switch(n) { 28 | case 1: return some(NW); 29 | case 2: return some(N ); 30 | case 3: return some(NE); 31 | case 4: return some(W ); 32 | case 5: return some(C ); 33 | case 6: return some(E ); 34 | case 7: return some(SW); 35 | case 8: return some(S); 36 | case 9: return some(SE); 37 | default: return none(); 38 | } 39 | } 40 | 41 | public static Option fromChar(final char c) { 42 | return fromInt(c - 48); 43 | } 44 | 45 | public final static F toChar = new F() { 46 | public Character f(final Position p) { 47 | return p.toChar(); 48 | } 49 | }; 50 | } 51 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/GameResult.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | import fj.data.Option; 5 | 6 | import static fj.data.Option.some; 7 | import static tictactoe.Player.Player1; 8 | import static tictactoe.Player.Player2; 9 | 10 | public enum GameResult { 11 | Player1Wins, Player2Wins, Draw; 12 | 13 | public boolean isWin() { 14 | return this == Player1Wins || this == Player2Wins; 15 | } 16 | 17 | public boolean isDraw() { 18 | return !isWin(); 19 | } 20 | 21 | public Option winner() { 22 | return this == Player1Wins ? 23 | some(Player1) : 24 | this == Player2Wins ? 25 | some(Player2) : 26 | Option.none(); 27 | } 28 | 29 | public X strictFold(final X player1Wins, final X player2Wins, final X draw) { 30 | return this == Player1Wins ? 31 | player1Wins : 32 | this == Player2Wins ? 33 | player2Wins : 34 | draw; 35 | } 36 | 37 | @Override 38 | public String toString() { 39 | return winner().option("draw", new F() { 40 | @Override 41 | public String f(final Player p) { 42 | return p.toString() + " wins"; 43 | } 44 | }); 45 | } 46 | 47 | public static GameResult win(final Player p) { 48 | return p == Player1 ? Player1Wins : Player2Wins; 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat/Chat.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat.Chat where 2 | 3 | import Network.Server.Common.Line 4 | import Network.Server.Chat.Loop 5 | import Data.Maybe(fromMaybe) 6 | import Data.Foldable(msum) 7 | import Data.IORef(atomicModifyIORef) 8 | import Control.Applicative((<$), (<$>)) 9 | import Control.Monad.Trans(MonadIO(..)) 10 | 11 | type Chat a = 12 | IORefLoop Integer a 13 | 14 | data ChatCommand = 15 | Chat String 16 | | Incr 17 | | Unknown String 18 | deriving (Eq, Show) 19 | 20 | incr :: 21 | Chat Integer 22 | incr = 23 | do e <- readEnvval 24 | liftIO $ atomicModifyIORef e (\n -> (n + 1, n + 1)) 25 | 26 | chat :: 27 | IO a 28 | chat = 29 | iorefLoop 0 (readIOEnvval >>= pPutStrLn . show) (process . chatCommand) 30 | 31 | -- | 32 | -- 33 | -- >>> chatCommand "CHAT hi" 34 | -- Chat "hi" 35 | -- 36 | -- >>> chatCommand "Chat bye" 37 | -- Chat "bye" 38 | -- 39 | -- >>> chatCommand "INCR" 40 | -- Incr 41 | -- 42 | -- >>> chatCommand "Nothing" 43 | -- UNKNOWN "Nothing" 44 | chatCommand :: 45 | String 46 | -> ChatCommand 47 | chatCommand z = 48 | Unknown z `fromMaybe` msum [ 49 | Chat <$> trimPrefixThen "CHAT" z 50 | , Incr <$ trimPrefixThen "INCR" z 51 | ] 52 | 53 | process :: 54 | ChatCommand 55 | -> Chat () 56 | process = 57 | error "todo" 58 | -------------------------------------------------------------------------------- /ops/ansible.yaml: -------------------------------------------------------------------------------- 1 | --- 2 | - name: "Install ansible deps (Python 2.7 stuff)" 3 | hosts: all 4 | user: ubuntu 5 | gather_facts: false 6 | tasks: 7 | - name: "Install ansible requirements" 8 | raw: apt-get update && apt-get install -y python2.7 python-simplejson 9 | become: yes 10 | 11 | - name: "Setup Ubuntu 16.04" 12 | hosts: all 13 | user: ubuntu 14 | 15 | tasks: 16 | - name: "Set ubuntu user's password to 'ubuntu'" 17 | user: 18 | name: ubuntu 19 | password: $6$hVCglTDqXKLR45$b4M1N30zbQmieXbHpqm3z1yYCZKNq1jF554WU7AwiBI/z8DkbV1zyE.aYeZvOkCgxsWIJv63IBEwB9riNmdyY/ 20 | become: yes 21 | 22 | - name: "Install packages" 23 | apt: 24 | name: "{{ item }}" 25 | update_cache: yes 26 | state: present 27 | become: yes 28 | with_items: 29 | - emacs 30 | - git 31 | - vim 32 | - xubuntu-desktop 33 | - virtualbox-guest-x11 34 | 35 | - name: "Automatically login as ubuntu user" 36 | lineinfile: 37 | line: autologin-user=ubuntu 38 | dest: /usr/share/lightdm/lightdm.conf.d/60-xubuntu.conf 39 | become: yes 40 | 41 | - name: "Checkout course repo" 42 | git: 43 | repo: https://github.com/data61/fp-course 44 | dest: ~/fp-course 45 | 46 | - include: haskell.yaml 47 | - include: vs-code.yaml 48 | - include: sublime.yaml 49 | 50 | - name: "Copy emacs.d" 51 | copy: 52 | src: emacs.d/ 53 | dest: ~/.emacs.d/ 54 | mode: 0755 55 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Line.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Line where 2 | 3 | import Data.Char(isSpace, toLower) 4 | import Data.Function(on) 5 | import Control.Monad.Trans(MonadIO(..)) 6 | import Control.Exception(IOException) 7 | 8 | -- | 9 | -- 10 | -- >>> trimPrefixThen "ABC" "AB" 11 | -- Nothing 12 | -- 13 | -- >>> trimPrefixThen "ABC" "ABC" 14 | -- Just "" 15 | -- 16 | -- >>> trimPrefixThen "ABC" "ABCDEF" 17 | -- Just "DEF" 18 | -- 19 | -- >>> trimPrefixThen "ABC" "Ab" 20 | -- Nothing 21 | -- 22 | -- >>> trimPrefixThen "ABC" "Abc" 23 | -- Just "" 24 | -- 25 | -- >>> trimPrefixThen "ABC" "Abcdef" 26 | -- Just "def" 27 | -- 28 | -- >>> trimPrefixThen "ABC" "Abcdef ghi " 29 | -- Just "def ghi" 30 | trimPrefixThen :: 31 | String 32 | -> String 33 | -> Maybe String 34 | trimPrefixThen l z = 35 | fmap (reverse . dropWhile isSpace . reverse . dropWhile isSpace) (prefixThen ((==) `on` toLower) l z) 36 | 37 | -- | 38 | -- 39 | -- >>> prefixThen (==) "ABC" "AB" 40 | -- Nothing 41 | -- 42 | -- >>> prefixThen (==) "ABC" "ABC" 43 | -- Just "" 44 | -- 45 | -- >>> prefixThen (==) "ABC" "ABCDEF" 46 | -- Just "DEF" 47 | prefixThen :: 48 | (a -> a -> Bool) 49 | -> [a] 50 | -> [a] 51 | -> Maybe [a] 52 | prefixThen _ [] r = 53 | Just r 54 | prefixThen _ _ [] = 55 | Nothing 56 | prefixThen e (a:b) (c:d) = 57 | if e a c 58 | then 59 | prefixThen e b d 60 | else 61 | Nothing 62 | 63 | xprint :: 64 | MonadIO m => 65 | IOException 66 | -> m () 67 | xprint = 68 | liftIO . print 69 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Player.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module TicTacToe.Player( 6 | Player(X, O) 7 | , AsPlayer(_Player) 8 | , playerswap 9 | ) where 10 | 11 | import Control.Applicative(Applicative) 12 | import Control.Category(id) 13 | import Control.Lens(Choice, Optic', Profunctor, Iso', iso, prism') 14 | import Data.Bool(Bool(False, True), bool) 15 | import Data.Eq(Eq) 16 | import Data.Functor(Functor) 17 | import Data.Maybe 18 | import Data.Int(Int) 19 | import Data.Ord(Ord) 20 | import Prelude(Show) 21 | 22 | data Player = 23 | X 24 | | O 25 | deriving (Eq, Ord, Show) 26 | 27 | class AsPlayer p f s where 28 | _Player :: 29 | Optic' p f s Player 30 | 31 | instance AsPlayer p f Player where 32 | _Player = 33 | id 34 | 35 | instance (Profunctor p, Functor f) => AsPlayer p f Bool where 36 | _Player = 37 | iso 38 | (bool O X) 39 | (\p -> case p of 40 | X -> True 41 | O -> False) 42 | 43 | instance (Choice p, Applicative f) => AsPlayer p f Int where 44 | _Player = 45 | prism' 46 | (\p -> case p of 47 | X -> 1 48 | O -> 2) 49 | (\n -> case n of 50 | 1 -> Just X 51 | 2 -> Just O 52 | _ -> Nothing) 53 | 54 | playerswap :: 55 | Iso' 56 | Player 57 | Player 58 | playerswap = 59 | let swap X = O 60 | swap O = X 61 | in iso 62 | swap 63 | swap 64 | 65 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Back.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | module TicTacToe.Back( 6 | Back(back) 7 | ) where 8 | 9 | import Control.Lens((^.)) 10 | import TicTacToe.Move(Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, Move9, _Move1, _Move2, _Move3, _Move4, _Move5, _Move6, _Move7, _Move8, Win5, Win6, Win7, Win8, Win9) 11 | 12 | class Back g f | g -> f where 13 | back :: 14 | g 15 | -> f 16 | 17 | instance Back Move9 Move8 where 18 | back = 19 | (^. _Move8) 20 | 21 | instance Back Win9 Move8 where 22 | back = 23 | (^. _Move8) 24 | 25 | instance Back Move8 Move7 where 26 | back = 27 | (^. _Move7) 28 | 29 | instance Back Win8 Move7 where 30 | back = 31 | (^. _Move7) 32 | 33 | instance Back Move7 Move6 where 34 | back = 35 | (^. _Move6) 36 | 37 | instance Back Win7 Move6 where 38 | back = 39 | (^. _Move6) 40 | 41 | instance Back Move6 Move5 where 42 | back = 43 | (^. _Move5) 44 | 45 | instance Back Win6 Move5 where 46 | back = 47 | (^. _Move5) 48 | 49 | instance Back Move5 Move4 where 50 | back = 51 | (^. _Move4) 52 | 53 | instance Back Win5 Move4 where 54 | back = 55 | (^. _Move4) 56 | 57 | instance Back Move4 Move3 where 58 | back = 59 | (^. _Move3) 60 | 61 | instance Back Move3 Move2 where 62 | back = 63 | (^. _Move2) 64 | 65 | instance Back Move2 Move1 where 66 | back = 67 | (^. _Move1) 68 | 69 | instance Back Move1 () where 70 | back _ = 71 | () 72 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/etc/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2013 National ICT Australia Limited 2012, 2013 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 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. Neither the name of the author nor the names of his contributors 14 | may be used to endorse or promote products derived from this software 15 | without specific prior written permission. 16 | 17 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 18 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 19 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 20 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 21 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 22 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 23 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 24 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 25 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 26 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 27 | SUCH DAMAGE. 28 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2010-2013 Tony Morris 2 | Copyright 2012-2015 National ICT Australia Limited 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions 8 | are met: 9 | 1. Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 3. Neither the name of the author nor the names of his contributors 15 | may be used to endorse or promote products derived from this software 16 | without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 19 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 20 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 21 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 22 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 23 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 24 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 25 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 26 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 27 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 28 | SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /etc/LICENCE: -------------------------------------------------------------------------------- 1 | Copyright 2010-2013 Tony Morris 2 | Copyright 2012-2016 National ICT Australia Limited 3 | Copyright 2017 Commonwealth Scientific and Industrial Research Organisation 4 | (CSIRO) ABN 41 687 119 230 5 | Copyright 2012 James Earl Douglas 6 | Copyright 2012 Ben Sinclair 7 | 8 | All rights reserved. 9 | 10 | Redistribution and use in source and binary forms, with or without 11 | modification, are permitted provided that the following conditions 12 | are met: 13 | 1. Redistributions of source code must retain the above copyright 14 | notice, this list of conditions and the following disclaimer. 15 | 2. Redistributions in binary form must reproduce the above copyright 16 | notice, this list of conditions and the following disclaimer in the 17 | documentation and/or other materials provided with the distribution. 18 | 3. Neither the name of the author nor the names of his contributors 19 | may be used to endorse or promote products derived from this software 20 | without specific prior written permission. 21 | 22 | THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND 23 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE 24 | IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE 25 | ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE 26 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 27 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 28 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 29 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT 30 | LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY 31 | OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF 32 | SUCH DAMAGE. 33 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/BoardLike.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | import fj.F2; 5 | import fj.P1; 6 | import fj.data.List; 7 | import fj.data.Option; 8 | 9 | import static fj.Monoid.stringMonoid; 10 | import static fj.data.List.list; 11 | import static tictactoe.Position.*; 12 | 13 | public abstract class BoardLike { 14 | public abstract Player whoseTurn(); 15 | public final Player whoseNotTurn() { 16 | return whoseTurn().alternate(); 17 | } 18 | public abstract boolean isEmpty(); 19 | public abstract List occupiedPositions(); 20 | public abstract int nmoves(); 21 | public abstract Option playerAt(Position p); 22 | public final Player playerAtOr(final Position p, final P1 or) { 23 | return playerAt(p).orSome(or); 24 | } 25 | public final boolean isOccupied(final Position p) { 26 | return playerAt(p).isSome(); 27 | } 28 | public final boolean isNotOccupied(final Position p) { 29 | return !isOccupied(p); 30 | } 31 | public final String toString(final F2, Position, Character> f) { 32 | final String z = ".===.===.===."; 33 | final F k = new F() { 34 | public String f(final Position p) { 35 | return f.f(playerAt(p), p).toString(); 36 | } 37 | }; 38 | 39 | 40 | final List i = 41 | list( 42 | z 43 | , stringMonoid.sumLeft().f(list("| ", k.f(NW), " | ", k.f(N ), " | ", k.f(NE), " |")) 44 | , z 45 | , stringMonoid.sumLeft().f(list("| ", k.f( W), " | ", k.f(C ), " | ", k.f( E), " |")) 46 | , z 47 | , stringMonoid.sumLeft().f(list("| ", k.f(SW), " | ", k.f(S ), " | ", k.f(SE), " |")) 48 | , z 49 | ).intersperse("\n"); 50 | 51 | return stringMonoid.sumLeft().f(i); 52 | } 53 | } 54 | -------------------------------------------------------------------------------- /src/Course/Core.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE RebindableSyntax #-} 4 | 5 | module Course.Core( 6 | Eq(..) 7 | , Ord(..) 8 | , Show(..) 9 | , Integral(..) 10 | , RealFrac(..) 11 | , Num(..) 12 | , Fractional(..) 13 | , Bool(..) 14 | , Either(..) 15 | , Int 16 | , Integer 17 | , IO 18 | , Rational 19 | , seq 20 | , error 21 | , undefined 22 | , const 23 | , flip 24 | , curry 25 | , uncurry 26 | , id 27 | , otherwise 28 | , (.) 29 | , ($) 30 | , (&&) 31 | , (||) 32 | , not 33 | , even 34 | , odd 35 | , fst 36 | , snd 37 | , getChar 38 | , on 39 | , first 40 | , second 41 | , (&&&) 42 | , (***) 43 | , IsString(..) 44 | , module Data.Char 45 | , ifThenElse 46 | , bool 47 | ) where 48 | 49 | 50 | import Prelude( 51 | Eq(..) 52 | , Ord(..) 53 | , Show(..) 54 | , Integral(..) 55 | , RealFrac(..) 56 | , Num(..) 57 | , Fractional(..) 58 | , Bool(..) 59 | , Either(..) 60 | , Char 61 | , Int 62 | , Integer 63 | , IO 64 | , Rational 65 | , seq 66 | , error 67 | , undefined 68 | , const 69 | , flip 70 | , curry 71 | , uncurry 72 | , id 73 | , otherwise 74 | , (.) 75 | , ($) 76 | , (&&) 77 | , (||) 78 | , not 79 | , even 80 | , odd 81 | , fst 82 | , snd 83 | ) 84 | import Data.String( 85 | IsString(..) 86 | ) 87 | 88 | import System.IO( 89 | getChar 90 | ) 91 | import Data.Function( 92 | on 93 | ) 94 | import Control.Arrow( 95 | first 96 | , second 97 | , (&&&) 98 | , (***) 99 | ) 100 | import Data.Char 101 | 102 | ifThenElse :: 103 | Bool 104 | -> a 105 | -> a 106 | -> a 107 | ifThenElse True t _ = 108 | t 109 | ifThenElse False _ f = 110 | f 111 | 112 | bool :: 113 | a 114 | -> a 115 | -> Bool 116 | -> a 117 | bool f _ False = 118 | f 119 | bool _ t True = 120 | t 121 | 122 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/MoveResult.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.F; 4 | import fj.Function; 5 | import fj.P; 6 | import fj.P1; 7 | import fj.data.Option; 8 | 9 | import static fj.P.p; 10 | 11 | public abstract class MoveResult { 12 | private MoveResult() {} 13 | 14 | public abstract X fold(P1 positionAlreadyOccupied, F keepPlaying, F gameOver); 15 | 16 | public Option keepPlaying() { 17 | return fold( 18 | p(Option.none()) 19 | , Option.some_() 20 | , Function.>constant(Option.none()) 21 | ); 22 | } 23 | 24 | public A keepPlayingOr(final P1 els, final F board) { 25 | return keepPlaying().option(els, board); 26 | } 27 | 28 | public MoveResult tryMove(final Position p) { 29 | return keepPlayingOr(P.p(this), new F() { 30 | public MoveResult f(final Board board) { 31 | return board.moveTo(p); 32 | } 33 | }); 34 | } 35 | 36 | public static MoveResult positionAlreadyOccupied() { 37 | return new MoveResult() { 38 | public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { 39 | return positionAlreadyOccupied._1(); 40 | } 41 | }; 42 | } 43 | 44 | public static MoveResult keepPlaying(final Board b) { 45 | return new MoveResult() { 46 | public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { 47 | return keepPlaying.f(b); 48 | } 49 | }; 50 | } 51 | 52 | public static MoveResult gameOver(final Board.FinishedBoard b) { 53 | return new MoveResult() { 54 | public X fold(final P1 positionAlreadyOccupied, final F keepPlaying, final F gameOver) { 55 | return gameOver.f(b); 56 | } 57 | }; 58 | } 59 | } 60 | -------------------------------------------------------------------------------- /etc/CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Tony Morris 2 | tmorris@tmorris.net 3 | http://tmorris.net/ 4 | -----BEGIN PGP PUBLIC KEY BLOCK----- 5 | Version: GnuPG v1.4.6 (GNU/Linux) 6 | 7 | mQGiBETNyC0RBAC3MYSZSbDZhBLKra2YUphB9OO6+qMFl/v2Lq8590ZfeE2WjIOu 8 | c/KGKyOigXztMrA4+iekUjM4FA8E6AlBRQiAqZK8HF0ftX5hDpuSyEKkZe3jcxxI 9 | BbhwX/SWHtDEVzwNmvO1wEnwhRE1oY/BCmy+bQ9wmAjlNav4UbOIcXcJUwCgz6FF 10 | UwDvPxzybgd9FNS14BE37n8D/AzGmGjunBW/x+g/ndwu6WEpTEn1ZNdja6VrNXSG 11 | xQ8XM+NBulroAIYX+YWdHsKnuGvSKCgVoc1ifVHdztA9sksID5GBGzhmVbIP2E16 12 | w/LEzqqwruv9dX0Y1b7n8hcnvbl4DgEgLgeQ+VgJfLUkY2jFZ2m3dEBRH9USSgB/ 13 | V2pBBACP4Us2ZBYEXtMG29g6GqyeeJLEP34PLYVHWJZbet/wPQsHFhYahhzjwZGG 14 | Srp0JUpegJOdaqX/Y0nio2whgCpqJcrbGuUBqNgQI3k4gvBwnPyx7jM0kfHfFORG 15 | lq9SDbfLpV0EJx6fWXGStW33zsQQvenDcV2F5czzKQcy66BFwbQhVG9ueSBNb3Jy 16 | aXMgPHRtb3JyaXNAdG1vcnJpcy5uZXQ+iGMEExECACMFAkTNyC0FCQlmAYAGCwkI 17 | BwMCBBUCCAMEFgIDAQIeAQIXgAAKCRCaemCth7qvrf0pAKCFii2pI2W1BKVFuQcw 18 | yoNxP0CAUACgyhuI9isCvtrOkeyjDmCVueRCdaC5Ag0ERM3IThAIAJ6A1z+d40ve 19 | WvPIhpFiGfoS8UX4YdgYpo2mC/orY0xszBitogtaTHQHU5YDemGg81plNg9I3DbM 20 | Er8uyONV4DqF6RbLj4w+iA6zn93+PTEZ73ydhxF6vDuojpVZPXVzXzpgyXHkEVLC 21 | 3hKL9oVlEsh+DWCvCiSAIy780JZ3FNVuMC3VH4qKxTw0CwPuuZvVfnMoIRfpODRR 22 | fVEk2VDor+lr8kqJkBaHgN5o/AvOXC7QCYadwbEkpr0ecxIZ1VcASYytIIM3YNL7 23 | ZcHWwU5PCNLOdMXPqOdthhDhsHkKJNEXXr0YsjX/bQqYOUqYKPDyqh/yrrRO9Ro6 24 | 7eTSbfIguycAAwcH/2waLIQR8qYKxPknNuSdsOOqF2jf2gglL/7uMsIzjfkFzgHo 25 | +GNHw9tmlZqD3yzaZ/N7Yv08ujRHhmWPBYAWRICBM3qo0zMJ9kI5XWRobeRQpLtf 26 | YxxIOenq8R9t6YU9ryHdqf+P+Fi38eN5ERTDhNLrJOnO5/TA+of97BWCmdtJMlWM 27 | RaHtqXxwo02Yi65IqKx6L7oOvT7Gh4NV2eglz8ZafPEoP8+V8ER7rwBYPiLk4Mse 28 | oVImjveq2dmLUip9OPwznoaeyC8zB0mJ13m/KNC+CffkBgoXpMPiKzbu5YTjVw++ 29 | MlEmfgL42yDK0hnokmW2i9y1RBh/T1VQQeQbUaeITAQYEQIADAUCRM3ITgUJCWYB 30 | gAAKCRCaemCth7qvrcbtAJ9j3C6lKNRB3uKcrfze66jAVQh0qACaAysOK82TcQ/2 31 | 73ryR0xWMFnpGqg= 32 | =bMTb 33 | -----END PGP PUBLIC KEY BLOCK----- 34 | 35 | Mark Hibberd 36 | mthibberd@gmail.com 37 | 38 | Ben Sinclair 39 | ben.d.sinclair@gmail.com 40 | 41 | James Earl Douglas 42 | james@earldouglas.com 43 | 44 | Eric Torreborre 45 | etorreborre@yahoo.com 46 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | \begin{code} 3 | {-# OPTIONS_GHC -Wall #-} 4 | module Main (main) where 5 | 6 | import Data.List ( nub ) 7 | import Data.Version ( showVersion ) 8 | import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) 9 | import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) 10 | import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) 11 | import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) 12 | import Distribution.Simple.BuildPaths ( autogenModulesDir ) 13 | import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) 14 | import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) 15 | import Distribution.Verbosity ( Verbosity ) 16 | import System.FilePath ( () ) 17 | 18 | main :: IO () 19 | main = defaultMainWithHooks simpleUserHooks 20 | { buildHook = \pkg lbi hooks flags -> do 21 | generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi 22 | buildHook simpleUserHooks pkg lbi hooks flags 23 | } 24 | 25 | generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () 26 | generateBuildModule verbosity pkg lbi = do 27 | let dir = autogenModulesDir lbi 28 | createDirectoryIfMissingVerbose verbosity True dir 29 | withLibLBI pkg lbi $ \_ libcfg -> do 30 | withTestLBI pkg lbi $ \suite suitecfg -> do 31 | rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines 32 | [ "module Build_" ++ testName suite ++ " where" 33 | , "deps :: [String]" 34 | , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) 35 | ] 36 | where 37 | formatdeps = map (formatone . snd) 38 | formatone p = case packageName p of 39 | PackageName n -> n ++ "-" ++ showVersion (packageVersion p) 40 | 41 | testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] 42 | testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys 43 | 44 | \end{code} 45 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | \begin{code} 3 | {-# OPTIONS_GHC -Wall #-} 4 | module Main (main) where 5 | 6 | import Data.List ( nub ) 7 | import Data.Version ( showVersion ) 8 | import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) 9 | import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) 10 | import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) 11 | import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) 12 | import Distribution.Simple.BuildPaths ( autogenModulesDir ) 13 | import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) 14 | import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) 15 | import Distribution.Verbosity ( Verbosity ) 16 | import System.FilePath ( () ) 17 | 18 | main :: IO () 19 | main = defaultMainWithHooks simpleUserHooks 20 | { buildHook = \pkg lbi hooks flags -> do 21 | generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi 22 | buildHook simpleUserHooks pkg lbi hooks flags 23 | } 24 | 25 | generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () 26 | generateBuildModule verbosity pkg lbi = do 27 | let dir = autogenModulesDir lbi 28 | createDirectoryIfMissingVerbose verbosity True dir 29 | withLibLBI pkg lbi $ \_ libcfg -> do 30 | withTestLBI pkg lbi $ \suite suitecfg -> do 31 | rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines 32 | [ "module Build_" ++ testName suite ++ " where" 33 | , "deps :: [String]" 34 | , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) 35 | ] 36 | where 37 | formatdeps = map (formatone . snd) 38 | formatone p = case packageName p of 39 | PackageName n -> n ++ "-" ++ showVersion (packageVersion p) 40 | 41 | testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] 42 | testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys 43 | 44 | \end{code} 45 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/OccupiedOr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module TicTacToe.OccupiedOr( 6 | OccupiedOr(Occupied, Or) 7 | , AsOccupiedOr(_OccupiedOr) 8 | ) where 9 | 10 | import Control.Applicative(Applicative((<*>), pure)) 11 | import Control.Category(id) 12 | import Control.Lens(Optic, Profunctor, Choice, prism', prism, iso) 13 | import Control.Monad(Monad((>>=), return)) 14 | import Data.Either(Either(Left, Right)) 15 | import Data.Eq(Eq) 16 | import Data.Functor(Functor(fmap)) 17 | import Data.Maybe(Maybe(Nothing, Just), maybe) 18 | import Data.Ord(Ord) 19 | import Prelude(Show) 20 | import TicTacToe.AsOccupied(AsOccupied(_Occupied)) 21 | import TicTacToe.AsOr(AsOr(_Or)) 22 | 23 | data OccupiedOr a = 24 | Occupied 25 | | Or a 26 | deriving (Eq, Ord, Show) 27 | 28 | class AsOccupiedOr p f o where 29 | _OccupiedOr :: 30 | Optic p f (o a) (o b) (OccupiedOr a) (OccupiedOr b) 31 | 32 | instance AsOccupiedOr p f OccupiedOr where 33 | _OccupiedOr = 34 | id 35 | 36 | instance (Profunctor p, Functor f) => AsOccupiedOr p f Maybe where 37 | _OccupiedOr = 38 | iso 39 | (maybe Occupied Or) 40 | (\o -> case o of 41 | Occupied -> Nothing 42 | Or a -> Just a) 43 | 44 | instance Functor OccupiedOr where 45 | fmap _ Occupied = 46 | Occupied 47 | fmap f (Or a) = 48 | Or (f a) 49 | 50 | instance Applicative OccupiedOr where 51 | pure = 52 | Or 53 | Occupied <*> _ = 54 | Occupied 55 | Or _ <*> Occupied = 56 | Occupied 57 | Or f <*> Or a = 58 | Or (f a) 59 | 60 | instance Monad OccupiedOr where 61 | return = 62 | Or 63 | Occupied >>= _ = 64 | Occupied 65 | Or a >>= f = 66 | f a 67 | 68 | instance (Choice p, Applicative f) => AsOccupied p f (OccupiedOr a) where 69 | _Occupied = 70 | prism' 71 | (\() -> Occupied) 72 | (\o -> case o of 73 | Occupied -> Just () 74 | Or _ -> Nothing) 75 | 76 | instance (Choice p, Applicative f) => AsOr p f OccupiedOr where 77 | _Or = 78 | prism 79 | Or 80 | (\o -> case o of 81 | Occupied -> Left Occupied 82 | Or a -> Right a) 83 | -------------------------------------------------------------------------------- /src/Course/Extend.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Extend where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.List 10 | import Course.Optional 11 | import Course.Functor 12 | 13 | -- | All instances of the `Extend` type-class must satisfy one law. This law 14 | -- is not checked by the compiler. This law is given as: 15 | -- 16 | -- * The law of associativity 17 | -- `∀f g. (f <<=) . (g <<=) ≅ (<<=) (f . (g <<=))` 18 | class Functor f => Extend f where 19 | -- Pronounced, extend. 20 | (<<=) :: 21 | (f a -> b) 22 | -> f a 23 | -> f b 24 | 25 | infixr 1 <<= 26 | 27 | -- | Implement the @Extend@ instance for @ExactlyOne@. 28 | -- 29 | -- >>> id <<= ExactlyOne 7 30 | -- ExactlyOne (ExactlyOne 7) 31 | instance Extend ExactlyOne where 32 | (<<=) :: 33 | (ExactlyOne a -> b) 34 | -> ExactlyOne a 35 | -> ExactlyOne b 36 | f <<= i = 37 | ExactlyOne (f i) 38 | 39 | -- | Implement the @Extend@ instance for @List@. 40 | -- 41 | -- >>> length <<= ('a' :. 'b' :. 'c' :. Nil) 42 | -- [3,2,1] 43 | -- 44 | -- >>> id <<= (1 :. 2 :. 3 :. 4 :. Nil) 45 | -- [[1,2,3,4],[2,3,4],[3,4],[4]] 46 | -- 47 | -- >>> reverse <<= ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil) 48 | -- [[[4,5,6],[1,2,3]],[[4,5,6]]] 49 | instance Extend List where 50 | (<<=) :: 51 | (List a -> b) 52 | -> List a 53 | -> List b 54 | _ <<= Nil = 55 | Nil 56 | f <<= x@(_:.t) = 57 | f x :. (f <<= t) 58 | 59 | -- | Implement the @Extend@ instance for @Optional@. 60 | -- 61 | -- >>> id <<= (Full 7) 62 | -- Full (Full 7) 63 | -- 64 | -- >>> id <<= Empty 65 | -- Empty 66 | instance Extend Optional where 67 | (<<=) :: 68 | (Optional a -> b) 69 | -> Optional a 70 | -> Optional b 71 | f <<= o = 72 | f . Full <$> o 73 | 74 | -- | Duplicate the functor using extension. 75 | -- 76 | -- >>> cojoin (ExactlyOne 7) 77 | -- ExactlyOne (ExactlyOne 7) 78 | -- 79 | -- >>> cojoin (1 :. 2 :. 3 :. 4 :. Nil) 80 | -- [[1,2,3,4],[2,3,4],[3,4],[4]] 81 | -- 82 | -- >>> cojoin (Full 7) 83 | -- Full (Full 7) 84 | -- 85 | -- >>> cojoin Empty 86 | -- Empty 87 | cojoin :: 88 | Extend f => 89 | f a 90 | -> f (f a) 91 | cojoin = 92 | (<<=) id 93 | -------------------------------------------------------------------------------- /test/Course/OptionalTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.OptionalTest where 5 | 6 | import Test.Tasty (TestTree, testGroup) 7 | import Test.Tasty.HUnit (testCase, (@?=)) 8 | 9 | import Course.Core 10 | import Course.Optional (Optional (..), bindOptional, mapOptional, 11 | (<+>), (??), optional) 12 | 13 | test_Optional :: TestTree 14 | test_Optional = 15 | testGroup "Optional" [ 16 | mapOptionalTest 17 | , bindOptionalTest 18 | , valueOrTest 19 | , firstFullTest 20 | , optionalTest 21 | ] 22 | 23 | mapOptionalTest :: TestTree 24 | mapOptionalTest = 25 | testGroup "mapOptional" [ 26 | testCase "Empty" $ 27 | mapOptional (+1) Empty @?= Empty 28 | , testCase "Full" $ 29 | mapOptional (+1) (Full 8) @?= Full 9 30 | ] 31 | 32 | bindOptionalTest :: TestTree 33 | bindOptionalTest = 34 | let evenDecOddInc n = if even n then Full (n - 1) else Full (n + 1) 35 | in testGroup "bindOptional" [ 36 | testCase "Empty" $ 37 | bindOptional Full Empty @?= (Empty :: Optional Integer) 38 | , testCase "even dec, odd inc, even input" $ 39 | bindOptional evenDecOddInc (Full 8) @?= Full 7 40 | , testCase "even dec, odd inc, odd input" $ 41 | bindOptional evenDecOddInc (Full 9) @?= Full 10 42 | ] 43 | 44 | valueOrTest :: TestTree 45 | valueOrTest = 46 | testGroup "??" [ 47 | testCase "Full" $ 48 | Full 8 ?? 99 @?= 8 49 | , testCase "Empty" $ 50 | Empty ?? 99 @?= 99 51 | ] 52 | 53 | firstFullTest :: TestTree 54 | firstFullTest = 55 | testGroup "<+>" [ 56 | testCase "first Full" $ 57 | Full 8 <+> Empty @?= Full 8 58 | , testCase "both Full" $ 59 | Full 8 <+> Full 9 @?= Full 8 60 | , testCase "first Empty" $ 61 | Empty <+> Full 9 @?= Full 9 62 | , testCase "both empty" $ 63 | Empty <+> Empty @?= (Empty :: Optional Integer) 64 | ] 65 | 66 | optionalTest :: TestTree 67 | optionalTest = 68 | testGroup "optional" [ 69 | testCase "replaces full data constructor" $ 70 | optional (+1) 0 (Full 8) @?= 9 71 | , testCase "replaces empty data constructor" $ 72 | optional (+1) 0 Empty @?= 0 73 | ] 74 | -------------------------------------------------------------------------------- /test/Course/FunctorTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Course.FunctorTest where 6 | 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?=)) 9 | import Test.Tasty.QuickCheck (testProperty) 10 | 11 | import Course.Core 12 | import Course.ExactlyOne (ExactlyOne (..)) 13 | import Course.Functor (void, (<$), (<$>)) 14 | import Course.List (List (..)) 15 | import Course.Optional (Optional (..)) 16 | 17 | test_Functor :: TestTree 18 | test_Functor = 19 | testGroup "Functor" [ 20 | idTest 21 | , listTest 22 | , optionalTest 23 | , functionTest 24 | , anonMapTest 25 | , voidTest 26 | ] 27 | 28 | idTest :: TestTree 29 | idTest = 30 | testCase "ExactlyOne" $ (+1) <$> ExactlyOne 2 @?= ExactlyOne 3 31 | 32 | listTest :: TestTree 33 | listTest = 34 | testGroup "List" [ 35 | testCase "empty list" $ 36 | (+1) <$> Nil @?= Nil 37 | , testCase "increment" $ 38 | (+1) <$> (1 :. 2 :. 3 :. Nil) @?= (2 :. 3 :. 4 :. Nil) 39 | ] 40 | 41 | optionalTest :: TestTree 42 | optionalTest = 43 | testGroup "Optional" [ 44 | testCase "Empty" $ (+1) <$> Empty @?= Empty 45 | , testCase "Full" $ (+1) <$> Full 2 @?= Full 3 46 | ] 47 | 48 | functionTest :: TestTree 49 | functionTest = 50 | testCase "(->)" $ ((+1) <$> (*2)) 8 @?= 17 51 | 52 | 53 | anonMapTest :: TestTree 54 | anonMapTest = 55 | testGroup "(<$)" [ 56 | testCase "Map 7" $ 7 <$ (1 :. 2 :. 3 :. Nil) @?= (7 :. 7 :. 7 :. Nil) 57 | , testProperty "Always maps a constant value over List" $ 58 | \x a b c -> (x :: Integer) <$ ((a :. b :. c :. Nil) :: List Integer) == (x :. x :. x :. Nil) 59 | , testProperty "Always maps a constant value over Full (Optional)" $ 60 | \(x :: Integer) (q :: Integer) -> x <$ Full q == Full x 61 | ] 62 | 63 | voidTest :: TestTree 64 | voidTest = 65 | testGroup "void" [ 66 | testCase "List" $ void (1 :. 2 :. 3 :. Nil) @?= () :. () :. () :. Nil 67 | , testCase "Full" $ void (Full 7) @?= Full () 68 | , testCase "Empty" $ void Empty @?= Empty 69 | , testCase "(->)" $ void (+10) 5 @?= () 70 | ] 71 | -------------------------------------------------------------------------------- /test/Course/ExtendTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.ExtendTest where 5 | 6 | 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?=)) 9 | 10 | import Course.Core 11 | import Course.ExactlyOne (ExactlyOne (ExactlyOne)) 12 | import Course.Functor ((<$>)) 13 | import Course.List (List (..), length, listh, reverse) 14 | import Course.Optional (Optional (..)) 15 | 16 | import Course.Extend (cojoin, (<<=)) 17 | 18 | test_Extend :: TestTree 19 | test_Extend = 20 | testGroup "Extend" [ 21 | exactlyOneTest 22 | , listTest 23 | , optionalTest 24 | , cojoinTest 25 | ] 26 | 27 | exactlyOneTest :: TestTree 28 | exactlyOneTest = 29 | testCase "ExactlyOne instance" $ 30 | (id <<= ExactlyOne 7) @?= ExactlyOne (ExactlyOne 7) 31 | 32 | listTest :: TestTree 33 | listTest = 34 | testGroup "List" [ 35 | testCase "length" $ 36 | (length <<= ('a' :. 'b' :. 'c' :. Nil)) @?= (3 :. 2 :. 1 :. Nil) 37 | , testCase "id" $ 38 | (id <<= (1 :. 2 :. 3 :. 4 :. Nil)) @?= nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] 39 | , testCase "reverse" $ 40 | (reverse <<= ((1 :. 2 :. 3 :. Nil) :. (4 :. 5 :. 6 :. Nil) :. Nil)) @?= 41 | nestedListh3 [[[4,5,6],[1,2,3]],[[4,5,6]]] 42 | ] 43 | 44 | optionalTest :: TestTree 45 | optionalTest = 46 | testGroup "Optional" [ 47 | testCase "id Full" $ 48 | (id <<= (Full 7)) @?= Full (Full 7) 49 | , testCase "id Empty" $ 50 | (id <<= Empty) @?= (Empty :: Optional (Optional Integer)) 51 | ] 52 | 53 | cojoinTest :: TestTree 54 | cojoinTest = 55 | testGroup "cojoin" [ 56 | testCase "ExactlyOne" $ 57 | cojoin (ExactlyOne 7) @?= ExactlyOne (ExactlyOne 7) 58 | , testCase "List" $ 59 | cojoin (1 :. 2 :. 3 :. 4 :. Nil) @?= nestedListh2 [[1,2,3,4],[2,3,4],[3,4],[4]] 60 | , testCase "Full" $ 61 | cojoin (Full 7) @?= Full (Full 7) 62 | , testCase "Empty" $ 63 | cojoin Empty @?= (Empty :: Optional (Optional Integer)) 64 | ] 65 | 66 | nestedListh2 :: [[a]] -> List (List a) 67 | nestedListh2 = (listh <$>) . listh 68 | 69 | nestedListh3 :: [[[a]]] -> List (List (List a)) 70 | nestedListh3 = ((listh <$>) <$>) . nestedListh2 71 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Common/Lens.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Common.Lens where 2 | 3 | -- | A lens is a pair of set and get. 4 | -- 5 | -- The type parameter 'a' denotes the target object. 6 | -- The type parameter 'b' denotes the field object. 7 | data Lens a b = 8 | Lens (a -> b -> a) (a -> b) 9 | 10 | -- | Given a lens and a target object, return its field object. 11 | getL :: 12 | Lens a b 13 | -> a 14 | -> b 15 | getL (Lens _ g) = 16 | g 17 | 18 | -- | Given a lens, a target object and a field object, return a new target object with the field set. 19 | setL :: 20 | Lens a b 21 | -> a 22 | -> b 23 | -> a 24 | setL (Lens s _) = 25 | s 26 | 27 | -- | Produce the lens for the first element of a pair. 28 | -- 29 | -- >>> getL fstL ("hi", 3) 30 | -- "hi" 31 | -- 32 | -- >>> setL fstL ("hi", 3) "bye" 33 | -- ("bye",3) 34 | fstL :: 35 | Lens (a, b) a 36 | fstL = 37 | Lens (\(_, b) a -> (a, b)) fst 38 | 39 | -- | Produce the lens for the second element of a pair. 40 | -- 41 | -- >>> getL sndL ("hi", 3) 42 | -- 3 43 | -- 44 | -- >>> setL sndL ("hi", 3) 4 45 | -- ("hi",4) 46 | sndL :: 47 | Lens (a, b) b 48 | sndL = 49 | Lens (\(a, _) b -> (a, b)) snd 50 | 51 | -- | Lens composition. 52 | -- Given lens (a to b) and lens (b to c), produce lens (a to c). 53 | -- 54 | -- >>> getL (fstL .@ sndL) (("hi", 3), [7,8,9]) 55 | -- 3 56 | -- 57 | -- >>> setL (fstL .@ sndL) (("hi", 3), [7,8,9]) 4 58 | -- (("hi",4),[7,8,9]) 59 | (.@) :: 60 | Lens a b 61 | -> Lens b c 62 | -> Lens a c 63 | Lens s1 g1 .@ Lens s2 g2 = 64 | Lens (\a -> s1 a . s2 (g1 a)) (g2 . g1) 65 | 66 | -- | Lens identity. 67 | -- Produce lens that /does nothing/. 68 | -- 69 | -- prop> getL identityL (x :: Int) == x 70 | -- 71 | -- prop> setL identityL x (y :: Int) == y 72 | identityL :: 73 | Lens a a 74 | identityL = 75 | Lens (const id) id 76 | 77 | -- | Lens modification. 78 | -- Given a lens and a modification function on the field object 79 | -- and a target object, return a target with the function applied at that field. 80 | -- 81 | -- >>> modify fstL (+10) (4, "hi") 82 | -- (14,"hi") 83 | modify :: 84 | Lens a b 85 | -> (b -> b) 86 | -> a 87 | -> a 88 | modify (Lens s g) f a = 89 | s a (f (g a)) 90 | 91 | iso :: 92 | (a -> b) 93 | -> (b -> a) 94 | -> Lens a b 95 | iso f g = 96 | Lens (const g) f 97 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/WinOccupiedOr.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | 5 | module TicTacToe.WinOccupiedOr( 6 | WinOccupiedOr(Win, IsOccupiedOr) 7 | , AsWinOccupiedOr(_WinOccupiedOr) 8 | ) where 9 | 10 | import Control.Applicative(Applicative(pure, (<*>))) 11 | import Control.Category((.), id) 12 | import Control.Lens(Optic, Choice, prism) 13 | import Control.Monad(Monad((>>=), return)) 14 | import Data.Either(Either(Left, Right)) 15 | import Data.Eq(Eq) 16 | import Data.Ord(Ord) 17 | import Data.Functor(Functor(fmap)) 18 | import TicTacToe.AsOccupied(AsOccupied(_Occupied)) 19 | import TicTacToe.AsOr(AsOr(_Or)) 20 | import TicTacToe.OccupiedOr(OccupiedOr(Occupied, Or), AsOccupiedOr(_OccupiedOr)) 21 | import TicTacToe.AsWin(AsWin(_Win)) 22 | import Prelude(Show) 23 | 24 | data WinOccupiedOr w a = 25 | Win w 26 | | IsOccupiedOr (OccupiedOr a) 27 | deriving (Eq, Ord, Show) 28 | 29 | class AsWinOccupiedOr p f o where 30 | _WinOccupiedOr :: 31 | Optic p f (o w a) (o x b) (WinOccupiedOr w a) (WinOccupiedOr x b) 32 | 33 | instance AsWinOccupiedOr p f WinOccupiedOr where 34 | _WinOccupiedOr = 35 | id 36 | 37 | instance Functor (WinOccupiedOr w) where 38 | fmap _ (Win w) = 39 | Win w 40 | fmap f (IsOccupiedOr m) = 41 | IsOccupiedOr (fmap f m) 42 | 43 | instance Applicative (WinOccupiedOr w) where 44 | pure = 45 | IsOccupiedOr . pure 46 | Win w <*> _ = 47 | Win w 48 | IsOccupiedOr _ <*> Win w = 49 | Win w 50 | IsOccupiedOr f <*> IsOccupiedOr a = 51 | IsOccupiedOr (f <*> a) 52 | 53 | instance Monad (WinOccupiedOr w) where 54 | return = 55 | IsOccupiedOr . return 56 | Win w >>= _ = 57 | Win w 58 | IsOccupiedOr m >>= f = 59 | case m of 60 | Occupied -> IsOccupiedOr Occupied 61 | Or a -> f a 62 | 63 | instance (Choice p, Applicative f) => AsWin p f WinOccupiedOr where 64 | _Win = 65 | prism 66 | Win 67 | (\b -> case b of 68 | Win w -> Right w 69 | IsOccupiedOr m -> Left (IsOccupiedOr m)) 70 | 71 | instance (Choice p, Applicative f) => AsOccupiedOr p f (WinOccupiedOr w) where 72 | _OccupiedOr = 73 | prism 74 | IsOccupiedOr 75 | (\b -> case b of 76 | Win w -> Left (Win w) 77 | IsOccupiedOr m -> Right m) 78 | 79 | instance (Choice p, Applicative f) => AsOccupied p f (WinOccupiedOr w a) where 80 | _Occupied = 81 | _OccupiedOr . _Occupied 82 | 83 | instance (Choice p, Applicative f) => AsOr p f (WinOccupiedOr w) where 84 | _Or = 85 | _OccupiedOr . _Or 86 | -------------------------------------------------------------------------------- /test/Course/MonadTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.MonadTest where 5 | 6 | import Test.Tasty (TestTree, testGroup) 7 | import Test.Tasty.HUnit (testCase, (@?=)) 8 | 9 | import Course.Core 10 | import Course.ExactlyOne (ExactlyOne (..)) 11 | import Course.List (List (..)) 12 | import Course.Monad (join, (<**>), (=<<), (>>=), (<=<)) 13 | import Course.Optional (Optional (..)) 14 | 15 | test_Monad :: TestTree 16 | test_Monad = 17 | testGroup "Monad" [ 18 | bindExactlyOneTest 19 | , bindListTest 20 | , bindOptionalTest 21 | , bindReaderTest 22 | , appTest 23 | , joinTest 24 | , bindFlippedTest 25 | , kleisliCompositionTest 26 | ] 27 | 28 | bindExactlyOneTest :: TestTree 29 | bindExactlyOneTest = 30 | testCase "(=<<) for ExactlyOne" $ 31 | ((\x -> ExactlyOne(x+1)) =<< ExactlyOne 2) @?= ExactlyOne 3 32 | 33 | bindListTest :: TestTree 34 | bindListTest = 35 | testCase "(=<<) for List" $ 36 | ((\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil)) @?= (1:.1:.2:.2:.3:.3:.Nil) 37 | 38 | bindOptionalTest :: TestTree 39 | bindOptionalTest = 40 | testCase "(=<<) for Optional" $ 41 | ((\n -> Full (n + n)) =<< Full 7) @?= Full 14 42 | 43 | bindReaderTest :: TestTree 44 | bindReaderTest = 45 | testCase "(=<<) for (->)" $ 46 | ((*) =<< (+10)) 7 @?= 119 47 | 48 | appTest :: TestTree 49 | appTest = 50 | testGroup "<**>" [ 51 | testCase "ExactlyOne" $ 52 | ExactlyOne (+10) <**> ExactlyOne 8 @?= ExactlyOne 18 53 | , testCase "List" $ 54 | (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil @?= (2:.3:.4:.2:.4:.6:.Nil) 55 | , testCase "Optional" $ 56 | Full (+8) <**> Full 7 @?= Full 15 57 | , testCase "Optional - empty function" $ 58 | Empty <**> Full 7 @?= (Empty :: Optional Integer) 59 | , testCase "Optional - empty value" $ 60 | Full (+8) <**> Empty @?= Empty 61 | , testCase "(->) 1" $ 62 | ((+) <**> (+10)) 3 @?= 16 63 | , testCase "(->) 2" $ 64 | ((+) <**> (+5)) 3 @?= 11 65 | , testCase "(->) 3" $ 66 | ((+) <**> (+5)) 1 @?= 7 67 | , testCase "(->) 4" $ 68 | ((*) <**> (+10)) 3 @?= 39 69 | , testCase "(->) 5" $ 70 | ((*) <**> (+2)) 3 @?= 15 71 | ] 72 | 73 | joinTest :: TestTree 74 | joinTest = 75 | testGroup "join" [ 76 | testCase "List" $ 77 | join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) @?= (1:.2:.3:.1:.2:.Nil) 78 | , testCase "Optional with Empty" $ 79 | join (Full Empty) @?= (Empty :: Optional Integer) 80 | , testCase "Optional all Full" $ 81 | join (Full (Full 7)) @?= Full 7 82 | , testCase "(->)" $ 83 | join (+) 7 @?= 14 84 | ] 85 | 86 | bindFlippedTest :: TestTree 87 | bindFlippedTest = 88 | testCase "(>>=)" $ 89 | ((+10) >>= (*)) 7 @?= 119 90 | 91 | kleisliCompositionTest :: TestTree 92 | kleisliCompositionTest = 93 | testCase "kleislyComposition" $ 94 | ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1 @?= (2:.2:.3:.3:.Nil) 95 | -------------------------------------------------------------------------------- /projects/TicTacToe/agda/TicTacToe.agda: -------------------------------------------------------------------------------- 1 | {- sent by user napping via IRC 20110629 licence unknown -} 2 | 3 | module tictactoe where 4 | open import Data.Bool hiding (_≟_) 5 | open import Data.Vec 6 | open import Data.Fin 7 | open import Data.Nat 8 | open import Data.Maybe 9 | open import Category.Monad 10 | open import Relation.Nullary.Core 11 | open import Data.Product hiding (map) 12 | 13 | data Cell : Set where 14 | X O b : Cell 15 | cell-eqb : Cell → Cell → Bool 16 | cell-eqb X X = true 17 | cell-eqb O O = true 18 | cell-eqb b b = true 19 | cell-eqb _ _ = false 20 | 21 | Board = Vec Cell 9 22 | 23 | startBoard : Board 24 | startBoard = tabulate (λ _ → b) 25 | 26 | triple-winner : Cell → Cell → Cell → Maybe Cell 27 | triple-winner X X X = just X 28 | triple-winner O O O = just O 29 | triple-winner _ _ _ = nothing 30 | 31 | winner : Board → Maybe Cell 32 | winner (ul ∷ uc ∷ ur ∷ ml ∷ mc ∷ mr ∷ bl ∷ bc ∷ br ∷ nil) = 33 | triple-winner ul uc ur ∣ triple-winner ml mc mr ∣ triple-winner bl bc br 34 | ∣ triple-winner ul ml bl ∣ triple-winner uc mc bc ∣ triple-winner ur mr br 35 | ∣ triple-winner ul mc br ∣ triple-winner ur mc bl 36 | where open RawMonadPlus monadPlus 37 | 38 | next-player : Board → Cell 39 | next-player board with sum (map Xs board) | sum (map Os board) 40 | where Xs : Cell → ℕ 41 | Xs X = 1 42 | Xs _ = 0 43 | Os : Cell → ℕ 44 | Os O = 1 45 | Os _ = 0 46 | next-player board | xs | os with xs ≟ os | xs ≟ suc os 47 | next-player board | xs | os | yes _ | _ = X 48 | next-player board | xs | os | _ | yes _ = O 49 | next-player board | xs | os | _ | _ = b 50 | 51 | validMove : Fin 9 → Cell → Board → Bool 52 | validMove p v board = cell-eqb b (lookup p board) 53 | ∧ maybe′ (λ _ → false) true (winner board) 54 | ∧ cell-eqb v (next-player board) 55 | 56 | data Game : Board → Set where 57 | startGame : Game startBoard 58 | move : (pos : Fin 9) → (val : Cell) → 59 | ∀ {board} → {ev : T (validMove pos val board)} → Game board 60 | → Game (board [ pos ]≔ val) 61 | 62 | started : Board → Bool 63 | started = foldr _ blank false 64 | where blank : Cell → Bool → Bool 65 | blank b f = f 66 | blank _ _ = true 67 | 68 | 69 | prevBoard : ∀ {board} → {ev : T (started board)} → (g : Game board) → Board 70 | prevBoard {ev = ()} startGame 71 | prevBoard (move pos val {board} y) = board 72 | 73 | takeBack : ∀ {board} → {ev : T (started board)} → (g : Game board) → 74 | Game (prevBoard {ev = ev} g) 75 | takeBack {ev = ()} startGame 76 | takeBack (move pos val {board} y) = y 77 | 78 | getBoard : ∀ {board} → Game board → Board 79 | getBoard {board} _ = board 80 | 81 | -- example 82 | 83 | state0 = startGame 84 | -- state0' = takeBack state0 -- not started 85 | state1 = move (# 4) X state0 86 | state2 = move (# 1) O state1 87 | -- state2' = move (# 0) X state1 -- out of turn 88 | state3 = takeBack state2 89 | state4 = move (# 0) O state3 90 | state5 = move (# 2) X state4 91 | -- state5' = move (# 0) X state4 -- already occupied 92 | state6 = move (# 6) O state5 93 | state7 = move (# 5) X state6 94 | state8 = move (# 3) O state7 95 | -- state9 = move (# 8) X state8 -- already finished 96 | 97 | -------------------------------------------------------------------------------- /src/Course/Optional.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Optional where 5 | 6 | import qualified Control.Applicative as A 7 | import qualified Control.Monad as M 8 | import Course.Core 9 | import qualified Prelude as P 10 | 11 | -- | The `Optional` data type contains 0 or 1 value. 12 | -- 13 | -- It might be thought of as a list, with a maximum length of one. 14 | data Optional a = 15 | Full a 16 | | Empty 17 | deriving (Eq, Show) 18 | 19 | -- | Map the given function on the possible value. 20 | -- 21 | -- >>> mapOptional (+1) Empty 22 | -- Empty 23 | -- 24 | -- >>> mapOptional (+1) (Full 8) 25 | -- Full 9 26 | mapOptional :: 27 | (a -> b) 28 | -> Optional a 29 | -> Optional b 30 | mapOptional _ Empty = 31 | Empty 32 | mapOptional f (Full a) = 33 | Full (f a) 34 | 35 | -- | Bind the given function on the possible value. 36 | -- 37 | -- >>> bindOptional Full Empty 38 | -- Empty 39 | -- 40 | -- >>> bindOptional (\n -> if even n then Full (n - 1) else Full (n + 1)) (Full 8) 41 | -- Full 7 42 | -- 43 | -- >>> bindOptional (\n -> if even n then Full (n - 1) else Full (n + 1)) (Full 9) 44 | -- Full 10 45 | bindOptional :: 46 | (a -> Optional b) 47 | -> Optional a 48 | -> Optional b 49 | bindOptional _ Empty = 50 | Empty 51 | bindOptional f (Full a) = 52 | f a 53 | 54 | -- | Return the possible value if it exists; otherwise, the second argument. 55 | -- 56 | -- >>> Full 8 ?? 99 57 | -- 8 58 | -- 59 | -- >>> Empty ?? 99 60 | -- 99 61 | (??) :: 62 | Optional a 63 | -> a 64 | -> a 65 | Empty ?? a = 66 | a 67 | Full a ?? _ = 68 | a 69 | 70 | -- | Try the first optional for a value. If it has a value, use it; otherwise, 71 | -- use the second value. 72 | -- 73 | -- >>> Full 8 <+> Empty 74 | -- Full 8 75 | -- 76 | -- >>> Full 8 <+> Full 9 77 | -- Full 8 78 | -- 79 | -- >>> Empty <+> Full 9 80 | -- Full 9 81 | -- 82 | -- >>> Empty <+> Empty 83 | -- Empty 84 | (<+>) :: 85 | Optional a 86 | -> Optional a 87 | -> Optional a 88 | Full a <+> _ = 89 | Full a 90 | Empty <+> x = 91 | x 92 | 93 | -- | Replaces the Full and Empty constructors in an optional. 94 | -- 95 | -- >>> optional (+1) 0 (Full 8) 96 | -- 9 97 | -- 98 | -- >>> optional (+1) 0 Empty 99 | -- 0 100 | optional :: 101 | (a -> b) 102 | -> b 103 | -> Optional a 104 | -> b 105 | optional _ e Empty = 106 | e 107 | optional f _ (Full a) = 108 | f a 109 | 110 | applyOptional :: Optional (a -> b) -> Optional a -> Optional b 111 | applyOptional f a = bindOptional (\f' -> mapOptional f' a) f 112 | 113 | twiceOptional :: (a -> b -> c) -> Optional a -> Optional b -> Optional c 114 | twiceOptional f = applyOptional . mapOptional f 115 | 116 | contains :: Eq a => a -> Optional a -> Bool 117 | contains _ Empty = False 118 | contains a (Full z) = a == z 119 | 120 | instance P.Functor Optional where 121 | fmap = 122 | M.liftM 123 | 124 | instance A.Applicative Optional where 125 | (<*>) = 126 | M.ap 127 | pure = 128 | Full 129 | 130 | instance P.Monad Optional where 131 | (>>=) = 132 | flip bindOptional 133 | return = 134 | Full 135 | -------------------------------------------------------------------------------- /src/Course/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | module Course.Validation where 5 | 6 | import qualified Prelude as P(String) 7 | import Course.Core 8 | 9 | -- class Validation { 10 | -- Validation(String error) {} // Error 11 | -- Validation(A value) {} // Value 12 | -- } 13 | 14 | -- $setup 15 | -- >>> import Test.QuickCheck 16 | -- >>> import qualified Prelude as P(fmap, either) 17 | -- >>> instance Arbitrary a => Arbitrary (Validation a) where arbitrary = P.fmap (P.either Error Value) arbitrary 18 | data Validation a = Error Err | Value a 19 | deriving (Eq, Show) 20 | 21 | type Err = P.String 22 | 23 | -- | Returns whether or not the given validation is an error. 24 | -- 25 | -- >>> isError (Error "message") 26 | -- True 27 | -- 28 | -- >>> isError (Value 7) 29 | -- False 30 | -- 31 | -- prop> \x -> isError x /= isValue x 32 | isError :: Validation a -> Bool 33 | isError (Error _) = True 34 | isError (Value _) = False 35 | 36 | -- | Returns whether or not the given validation is a value. 37 | -- 38 | -- >>> isValue (Error "message") 39 | -- False 40 | -- 41 | -- >>> isValue (Value 7) 42 | -- True 43 | -- 44 | -- prop> \x -> isValue x /= isError x 45 | isValue :: Validation a -> Bool 46 | isValue = not . isError 47 | 48 | -- | Maps a function on a validation's value side. 49 | -- 50 | -- >>> mapValidation (+10) (Error "message") 51 | -- Error "message" 52 | -- 53 | -- >>> mapValidation (+10) (Value 7) 54 | -- Value 17 55 | -- 56 | -- prop> \x -> mapValidation id x == x 57 | mapValidation :: (a -> b) -> Validation a -> Validation b 58 | mapValidation _ (Error s) = Error s 59 | mapValidation f (Value a) = Value (f a) 60 | 61 | -- | Binds a function on a validation's value side to a new validation. 62 | -- 63 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Error "message") 64 | -- Error "message" 65 | -- 66 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Value 7) 67 | -- Error "odd" 68 | -- 69 | -- >>> bindValidation (\n -> if even n then Value (n + 10) else Error "odd") (Value 8) 70 | -- Value 18 71 | -- 72 | -- prop> \x -> bindValidation Value x == x 73 | bindValidation :: (a -> Validation b) -> Validation a -> Validation b 74 | bindValidation _ (Error s) = Error s 75 | bindValidation f (Value a) = f a 76 | 77 | -- | Returns a validation's value side or the given default if it is an error. 78 | -- 79 | -- >>> valueOr (Error "message") 3 80 | -- 3 81 | -- 82 | -- >>> valueOr (Value 7) 3 83 | -- 7 84 | -- 85 | -- prop> \x -> isValue x || valueOr x n == n 86 | valueOr :: Validation a -> a -> a 87 | valueOr (Error _) a = a 88 | valueOr (Value a) _ = a 89 | 90 | -- | Returns a validation's error side or the given default if it is a value. 91 | -- 92 | -- >>> errorOr (Error "message") "q" 93 | -- "message" 94 | -- 95 | -- >>> errorOr (Value 7) "q" 96 | -- "q" 97 | -- 98 | -- prop> \x -> isError x || errorOr x e == e 99 | errorOr :: Validation a -> Err -> Err 100 | errorOr (Error e) _ = e 101 | errorOr (Value _) a = a 102 | 103 | valueValidation :: a -> Validation a 104 | valueValidation = Value 105 | -------------------------------------------------------------------------------- /src/Course/Functor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Functor where 6 | 7 | import Course.Core 8 | import Course.ExactlyOne 9 | import Course.Optional 10 | import Course.List 11 | import qualified Prelude as P(fmap) 12 | 13 | -- | All instances of the `Functor` type-class must satisfy two laws. These laws 14 | -- are not checked by the compiler. These laws are given as: 15 | -- 16 | -- * The law of identity 17 | -- `∀x. (id <$> x) ≅ x` 18 | -- 19 | -- * The law of composition 20 | -- `∀f g x.(f . g <$> x) ≅ (f <$> (g <$> x))` 21 | class Functor f where 22 | -- Pronounced, eff-map. 23 | (<$>) :: 24 | (a -> b) 25 | -> f a 26 | -> f b 27 | 28 | infixl 4 <$> 29 | 30 | -- $setup 31 | -- >>> :set -XOverloadedStrings 32 | -- >>> import Course.Core 33 | -- >>> import qualified Prelude as P(return, (>>)) 34 | 35 | -- | Maps a function on the ExactlyOne functor. 36 | -- 37 | -- >>> (+1) <$> ExactlyOne 2 38 | -- ExactlyOne 3 39 | instance Functor ExactlyOne where 40 | (<$>) :: 41 | (a -> b) 42 | -> ExactlyOne a 43 | -> ExactlyOne b 44 | f <$> ExactlyOne a = 45 | ExactlyOne (f a) 46 | 47 | -- | Maps a function on the List functor. 48 | -- 49 | -- >>> (+1) <$> Nil 50 | -- [] 51 | -- 52 | -- >>> (+1) <$> (1 :. 2 :. 3 :. Nil) 53 | -- [2,3,4] 54 | instance Functor List where 55 | (<$>) :: 56 | (a -> b) 57 | -> List a 58 | -> List b 59 | (<$>) f = 60 | foldRight (\a b -> f a :. b) Nil 61 | 62 | -- | Maps a function on the Optional functor. 63 | -- 64 | -- >>> (+1) <$> Empty 65 | -- Empty 66 | -- 67 | -- >>> (+1) <$> Full 2 68 | -- Full 3 69 | instance Functor Optional where 70 | (<$>) :: 71 | (a -> b) 72 | -> Optional a 73 | -> Optional b 74 | (<$>) f = 75 | optional (Full . f) Empty 76 | 77 | -- | Maps a function on the reader ((->) t) functor. 78 | -- 79 | -- >>> ((+1) <$> (*2)) 8 80 | -- 17 81 | instance Functor ((->) t) where 82 | (<$>) :: 83 | (a -> b) 84 | -> ((->) t a) 85 | -> ((->) t b) 86 | f <$> g = 87 | \x -> f (g x) 88 | 89 | -- | Anonymous map. Maps a constant value on a functor. 90 | -- 91 | -- >>> 7 <$ (1 :. 2 :. 3 :. Nil) 92 | -- [7,7,7] 93 | -- 94 | -- prop> \x a b c -> x <$ (a :. b :. c :. Nil) == (x :. x :. x :. Nil) 95 | -- 96 | -- prop> \x q -> x <$ Full q == Full x 97 | (<$) :: 98 | Functor f => 99 | a 100 | -> f b 101 | -> f a 102 | (<$) = 103 | (<$>) . const 104 | 105 | -- | Anonymous map producing unit value. 106 | -- 107 | -- >>> void (1 :. 2 :. 3 :. Nil) 108 | -- [(),(),()] 109 | -- 110 | -- >>> void (Full 7) 111 | -- Full () 112 | -- 113 | -- >>> void Empty 114 | -- Empty 115 | -- 116 | -- >>> void (+10) 5 117 | -- () 118 | void :: 119 | Functor f => 120 | f a 121 | -> f () 122 | void = 123 | (<$) () 124 | 125 | ----------------------- 126 | -- SUPPORT LIBRARIES -- 127 | ----------------------- 128 | 129 | -- | Maps a function on an IO program. 130 | -- 131 | -- >>> reverse <$> (putStr "hi" P.>> P.return ("abc" :: List Char)) 132 | -- hi"cba" 133 | instance Functor IO where 134 | (<$>) = 135 | P.fmap 136 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/tictactoe.cabal: -------------------------------------------------------------------------------- 1 | name: tictactoe 2 | version: 0.1.0 3 | license: BSD3 4 | license-file: LICENSE 5 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 6 | maintainer: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 7 | copyright: Copyright (C) 2010-2013 Tony Morris 8 | copyright: Copyright (C) 2012-2015 NICTA Limited 9 | synopsis: A model of the game of Tic-Tac-Toe 10 | category: Data 11 | description: 12 | <> 13 | . 14 | A model of the game of Tic-Tac-Toe enforcing game properties with types 15 | 16 | homepage: https://github.com/NICTA/course 17 | bug-reports: https://github.com/NICTA/course/issues 18 | cabal-version: >= 1.10 19 | build-type: Custom 20 | extra-source-files: changelog 21 | 22 | source-repository head 23 | type: git 24 | location: git@github.com:NICTA/course.git 25 | 26 | flag small_base 27 | description: Choose the new, split-up base package. 28 | 29 | library 30 | default-language: 31 | Haskell2010 32 | 33 | build-depends: 34 | base >= 4 && < 5 35 | , lens >= 4 && < 5 36 | , tagged >= 0.8 && < 0.9 37 | 38 | ghc-options: 39 | -Wall 40 | 41 | default-extensions: 42 | NoImplicitPrelude 43 | 44 | hs-source-dirs: 45 | src 46 | 47 | exposed-modules: 48 | TicTacToe 49 | TicTacToe.AsOccupied 50 | TicTacToe.AsOr 51 | TicTacToe.AsWin 52 | TicTacToe.Back 53 | TicTacToe.Draw 54 | TicTacToe.Move 55 | TicTacToe.MoveOr 56 | TicTacToe.Player 57 | TicTacToe.Position 58 | TicTacToe.OccupiedOr 59 | TicTacToe.WinOccupiedOr 60 | TicTacToe.Winpaths 61 | TicTacToe.WithPosition 62 | 63 | executable tictactoe 64 | default-language: 65 | Haskell2010 66 | 67 | build-depends: 68 | base >= 4 && < 5 69 | , lens >= 4 && < 5 70 | , tagged >= 0.8 && < 0.9 71 | , ansi-terminal 72 | 73 | hs-source-dirs: 74 | src 75 | 76 | main-is: 77 | TicTacToe/Console.hs 78 | 79 | ghc-options: 80 | -Wall 81 | 82 | 83 | test-suite doctests 84 | type: 85 | exitcode-stdio-1.0 86 | 87 | main-is: 88 | doctests.hs 89 | 90 | default-language: 91 | Haskell2010 92 | 93 | build-depends: 94 | base < 5 && >= 3 95 | , doctest >= 0.9.7 96 | , filepath >= 1.3 97 | , directory >= 1.1 98 | , QuickCheck >= 2.0 99 | , template-haskell >= 2.8 100 | 101 | ghc-options: 102 | -Wall 103 | -threaded 104 | 105 | hs-source-dirs: 106 | test 107 | -------------------------------------------------------------------------------- /test/Course/ValidationTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | 6 | module Course.ValidationTest where 7 | 8 | import qualified Prelude as P (either, fmap) 9 | import Test.Tasty 10 | import Test.Tasty.HUnit 11 | import Test.Tasty.QuickCheck 12 | 13 | import Course.Core 14 | import Course.Validation 15 | 16 | instance Arbitrary a => Arbitrary (Validation a) where 17 | arbitrary = P.fmap (P.either Error Value) arbitrary 18 | 19 | test_Validation :: TestTree 20 | test_Validation = 21 | testGroup "Validation" [ 22 | isErrorTest 23 | , isValueTest 24 | , mapValidationTest 25 | , bindValidationTest 26 | , valueOrTest 27 | , errorOrTest 28 | ] 29 | 30 | isErrorTest :: TestTree 31 | isErrorTest = 32 | testGroup "isError" [ 33 | testCase "true for errors" $ 34 | isError (Error "Message") @?= True 35 | , testCase "false for values" $ 36 | isError (Value "7") @?= False 37 | , testProperty "not the same as isValue" $ 38 | \(x :: Validation Int) -> isError x /= isValue x 39 | ] 40 | 41 | isValueTest :: TestTree 42 | isValueTest = 43 | testGroup "isValue" [ 44 | testCase "false for errors" $ 45 | isValue (Error "Message") @?= False 46 | , testCase "false for values" $ 47 | isValue (Value "7") @?= True 48 | , testProperty "not the same as isValue" $ 49 | \(x :: Validation Int) -> isValue x /= isError x 50 | ] 51 | 52 | mapValidationTest :: TestTree 53 | mapValidationTest = 54 | testGroup "mapValidation" [ 55 | testCase "errors unchanged" $ 56 | mapValidation (+ 10) (Error "message") @?= Error "message" 57 | , testCase "values changed" $ 58 | mapValidation (+ 10) (Value 7) @?= Value 17 59 | , testProperty "map with id causes no change" $ 60 | \(x :: Validation Int) -> mapValidation id x == x 61 | ] 62 | 63 | bindValidationTest :: TestTree 64 | bindValidationTest = 65 | let 66 | f n = if even n then Value (n + 10) else Error "odd" 67 | in 68 | testGroup "bindValidation" [ 69 | testCase "error unchanged" $ 70 | bindValidation f (Error "message") @?= Error "message" 71 | , testCase "odd value" $ 72 | bindValidation f (Value 7) @?= Error "odd" 73 | , testCase "even value" $ 74 | bindValidation f (Value 8) @?= Value 18 75 | , testProperty "bind with Value causes no change" $ 76 | \(x :: Validation Int) -> bindValidation Value x == x 77 | ] 78 | 79 | valueOrTest :: TestTree 80 | valueOrTest = 81 | testGroup "valueOr" [ 82 | testCase "falls through for errors" $ 83 | valueOr (Error "message") "foo" @?= "foo" 84 | , testCase "unwraps values" $ 85 | valueOr (Value "foo") "bar" @?= "foo" 86 | , testProperty "isValue or valueOr falls through" $ 87 | \(x :: Validation Int) n -> isValue x || valueOr x n == n 88 | ] 89 | 90 | errorOrTest :: TestTree 91 | errorOrTest = 92 | testGroup "errorOr" [ 93 | testCase "unwraps errors" $ 94 | errorOr (Error "message") "q" @?= "message" 95 | , testCase "falls through for values" $ 96 | errorOr (Value (7 :: Integer)) "q" @?= "q" 97 | , testProperty "isError or errorOr falls through" $ 98 | \(x :: Validation Int) n -> isError x || errorOr x n == n 99 | ] 100 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/network-server.cabal: -------------------------------------------------------------------------------- 1 | name: network-server 2 | version: 0.0.1 3 | license: BSD3 4 | license-File: etc/LICENCE 5 | author: Tony Morris <ʇǝu˙sıɹɹoɯʇ@ןןǝʞsɐɥ> 6 | maintainer: Tony Morris 7 | copyright: Copyright (C) 2013 National ICT Australia Limited 2013 8 | synopsis: A network server 9 | category: Education 10 | description: A network server 11 | homepage: https://github.com/data61/fp-course 12 | bug-reports: https://github.com/data61/fp-course/issues 13 | cabal-version: >= 1.10 14 | build-type: Custom 15 | 16 | custom-setup 17 | setup-depends: Cabal >= 1.24 && < 2 18 | , base >= 4.8 && < 5 19 | , filepath >= 1.4 && < 1.5 20 | 21 | source-repository head 22 | type: git 23 | location: git@github.com:data61/fp-course.git 24 | 25 | executable network-tictactoe 26 | default-language: Haskell2010 27 | 28 | main-is: Network/Server/TicTacToe/Main.hs 29 | 30 | hs-source-dirs: src 31 | 32 | build-depends: base < 5 && >= 4 33 | , network-server 34 | , mtl 35 | , containers 36 | , network 37 | , QuickCheck 38 | 39 | ghc-options: -Wall 40 | 41 | executable network-chat 42 | default-language: Haskell2010 43 | 44 | main-is: Network/Server/Chat/Main.hs 45 | 46 | hs-source-dirs: src 47 | 48 | build-depends: base < 5 && >= 4 49 | , network-server 50 | , mtl 51 | , containers 52 | , network 53 | , QuickCheck 54 | 55 | ghc-options: -Wall 56 | 57 | library 58 | default-language: Haskell2010 59 | 60 | build-depends: base < 5 && >= 4 61 | , mtl 62 | , containers 63 | , network 64 | , QuickCheck 65 | 66 | ghc-options: -Wall 67 | 68 | hs-source-dirs: src 69 | 70 | exposed-modules: 71 | Network.Server.Chat.Chat 72 | , Network.Server.Chat.Loop 73 | , Network.Server.Chat 74 | , Network.Server.Common.Accept 75 | , Network.Server.Common.Env 76 | , Network.Server.Common.HandleLens 77 | , Network.Server.Common.Lens 78 | , Network.Server.Common.Line 79 | , Network.Server.Common.Ref 80 | , Network.Server.Common 81 | , Network.Server.TicTacToe.Game 82 | , Network.Server.TicTacToe.Loop 83 | , Network.Server.TicTacToe 84 | , Network.Server 85 | 86 | test-suite doctests 87 | type: 88 | exitcode-stdio-1.0 89 | 90 | main-is: 91 | doctests.hs 92 | 93 | default-language: 94 | Haskell2010 95 | 96 | build-depends: 97 | base < 5 && >= 3, 98 | doctest >= 0.9.7, 99 | filepath >= 1.3, 100 | directory >= 1.1, 101 | QuickCheck >= 2.0 102 | 103 | ghc-options: 104 | -Wall 105 | -threaded 106 | 107 | hs-source-dirs: 108 | test 109 | -------------------------------------------------------------------------------- /src/Course/FileIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.FileIO where 7 | 8 | import Course.Core 9 | import Course.Applicative 10 | import Course.Monad 11 | import Course.Functor 12 | import Course.List 13 | 14 | {- 15 | 16 | Useful Functions -- 17 | 18 | getArgs :: IO (List Chars) 19 | putStrLn :: Chars -> IO () 20 | readFile :: FilePath -> IO Chars 21 | lines :: Chars -> List Chars 22 | void :: IO a -> IO () 23 | 24 | Abstractions -- 25 | Applicative, Monad: 26 | 27 | <$>, <*>, >>=, =<<, pure 28 | 29 | Tuple Functions that could help -- 30 | 31 | fst :: (a, b) -> a 32 | snd :: (a, b) -> b 33 | (,) :: a -> b -> (a, b) 34 | 35 | Problem -- 36 | Given a single argument of a file name, read that file, 37 | each line of that file contains the name of another file, 38 | read the referenced file and print out its name and contents. 39 | 40 | Consideration -- 41 | Try to avoid repetition. Factor out any common expressions. 42 | 43 | Example -- 44 | Given file files.txt, containing: 45 | a.txt 46 | b.txt 47 | c.txt 48 | 49 | And a.txt, containing: 50 | the contents of a 51 | 52 | And b.txt, containing: 53 | the contents of b 54 | 55 | And c.txt, containing: 56 | the contents of c 57 | 58 | To test this module, load ghci in the root of the project directory, and do 59 | >> :main "share/files.txt" 60 | 61 | Example output: 62 | 63 | $ ghci 64 | GHCi, version ... 65 | Loading package... 66 | Loading ... 67 | [ 1 of 28] Compiling (etc... 68 | ... 69 | Ok, modules loaded: Course, etc... 70 | >> :main "share/files.txt" 71 | ============ share/a.txt 72 | the contents of a 73 | 74 | ============ share/b.txt 75 | the contents of b 76 | 77 | ============ share/c.txt 78 | the contents of c 79 | 80 | -} 81 | 82 | -- Given the file name, and file contents, print them. 83 | -- Use @putStrLn@. 84 | printFile :: 85 | FilePath 86 | -> Chars 87 | -> IO () 88 | printFile name content = 89 | putStrLn ("============ " ++ name) >> 90 | putStrLn content 91 | 92 | -- Given a list of (file name and file contents), print each. 93 | -- Use @printFile@. 94 | printFiles :: 95 | List (FilePath, Chars) 96 | -> IO () 97 | printFiles = 98 | void . sequence . (<$>) (uncurry printFile) 99 | 100 | -- Given a file name, return (file name and file contents). 101 | -- Use @readFile@. 102 | getFile :: 103 | FilePath 104 | -> IO (FilePath, Chars) 105 | getFile = 106 | lift2 (<$>) (,) readFile 107 | 108 | -- Given a list of file names, return list of (file name and file contents). 109 | -- Use @getFile@. 110 | getFiles :: 111 | List FilePath 112 | -> IO (List (FilePath, Chars)) 113 | getFiles = 114 | sequence . (<$>) getFile 115 | 116 | -- Given a file name, read it and for each line in that file, read and print contents of each. 117 | -- Use @getFiles@ and @printFiles@. 118 | run :: 119 | FilePath 120 | -> IO () 121 | run filename = 122 | do 123 | content <- readFile filename 124 | results <- getFiles (lines content) 125 | printFiles results 126 | 127 | -- /Tip:/ use @getArgs@ and @run@ 128 | main :: 129 | IO () 130 | main = 131 | getArgs >>= \args -> 132 | case args of 133 | filename :. Nil -> run filename 134 | _ -> putStrLn "usage: runhaskell io.hs filename" 135 | 136 | ---- 137 | 138 | -- Was there was some repetition in our solution? 139 | -- ? `sequence . (<$>)` 140 | -- ? `void . sequence . (<$>)` 141 | -- Factor it out. 142 | -------------------------------------------------------------------------------- /src/Course/Traversable.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | 5 | module Course.Traversable where 6 | 7 | import Course.Core 8 | import Course.Functor 9 | import Course.Applicative 10 | import Course.List 11 | import Course.ExactlyOne 12 | import Course.Optional 13 | import Course.Compose 14 | 15 | -- | All instances of the `Traversable` type-class must satisfy three laws. These 16 | -- laws are not checked by the compiler. These laws are given as: 17 | -- 18 | -- * The law of naturality 19 | -- `∀f g. f . traverse g ≅ traverse (f . g)` 20 | -- 21 | -- * The law of identity 22 | -- `∀x. traverse ExactlyOne x ≅ ExactlyOne x` 23 | -- 24 | -- * The law of composition 25 | -- `∀f g. traverse ((g <$>) . f) ≅ (traverse g <$>) . traverse f` 26 | class Functor t => Traversable t where 27 | traverse :: 28 | Applicative f => 29 | (a -> f b) 30 | -> t a 31 | -> f (t b) 32 | 33 | instance Traversable List where 34 | traverse :: 35 | Applicative f => 36 | (a -> f b) 37 | -> List a 38 | -> f (List b) 39 | traverse f = 40 | foldRight (\a b -> (:.) <$> f a <*> b) (pure Nil) 41 | 42 | instance Traversable ExactlyOne where 43 | traverse :: 44 | Applicative f => 45 | (a -> f b) 46 | -> ExactlyOne a 47 | -> f (ExactlyOne b) 48 | traverse f (ExactlyOne a) = 49 | ExactlyOne <$> f a 50 | 51 | instance Traversable Optional where 52 | traverse :: 53 | Applicative f => 54 | (a -> f b) 55 | -> Optional a 56 | -> f (Optional b) 57 | traverse _ Empty = 58 | pure Empty 59 | traverse f (Full a) = 60 | Full <$> f a 61 | 62 | -- | Sequences a traversable value of structures to a structure of a traversable value. 63 | -- 64 | -- >>> sequenceA (ExactlyOne 7 :. ExactlyOne 8 :. ExactlyOne 9 :. Nil) 65 | -- ExactlyOne [7,8,9] 66 | -- 67 | -- >>> sequenceA (Full (ExactlyOne 7)) 68 | -- ExactlyOne (Full 7) 69 | -- 70 | -- >>> sequenceA (Full (*10)) 6 71 | -- Full 60 72 | sequenceA :: 73 | (Applicative f, Traversable t) => 74 | t (f a) 75 | -> f (t a) 76 | sequenceA = 77 | traverse id 78 | 79 | instance (Traversable f, Traversable g) => 80 | Traversable (Compose f g) where 81 | -- Implement the traverse function for a Traversable instance for Compose 82 | traverse f (Compose x) = 83 | Compose <$> traverse (traverse f) x 84 | 85 | -- | The `Product` data type contains one value from each of the two type constructors. 86 | data Product f g a = 87 | Product (f a) (g a) deriving (Show, Eq) 88 | 89 | instance (Functor f, Functor g) => 90 | Functor (Product f g) where 91 | -- Implement the (<$>) function for a Functor instance for Product 92 | f <$> Product a b = 93 | Product (f <$> a) (f <$> b) 94 | 95 | instance (Traversable f, Traversable g) => 96 | Traversable (Product f g) where 97 | -- Implement the traverse function for a Traversable instance for Product 98 | traverse f (Product a b) = 99 | Product <$> traverse f a <*> traverse f b 100 | 101 | -- | The `Coproduct` data type contains one value from either of the two type constructors. 102 | data Coproduct f g a = 103 | InL (f a) 104 | | InR (g a) deriving (Show, Eq) 105 | 106 | instance (Functor f, Functor g) => 107 | Functor (Coproduct f g) where 108 | -- Implement the (<$>) function for a Functor instance for Coproduct 109 | f <$> InL a = 110 | InL (f <$> a) 111 | f <$> InR b = 112 | InR (f <$> b) 113 | 114 | instance (Traversable f, Traversable g) => 115 | Traversable (Coproduct f g) where 116 | -- Implement the traverse function for a Traversable instance for Coproduct 117 | traverse f (InL a) = 118 | InL <$> traverse f a 119 | traverse f (InR b) = 120 | InR <$> traverse f b 121 | -------------------------------------------------------------------------------- /test/Course/Gens.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.Gens where 5 | 6 | import qualified Prelude as P (fmap, foldr, (<$>), (<*>)) 7 | import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable, 8 | forAllShrink) 9 | 10 | import Course.Core 11 | import Course.List (List (..), hlist, listh) 12 | import Course.ListZipper (ListZipper (..), zipper) 13 | 14 | genList :: Arbitrary a => Gen (List a) 15 | genList = P.fmap ((P.foldr (:.) Nil) :: [a] -> List a) arbitrary 16 | 17 | shrinkList :: Arbitrary a => List a -> [List a] 18 | shrinkList = 19 | P.fmap listh . shrink . hlist 20 | 21 | genIntegerList :: Gen (List Integer) 22 | genIntegerList = genList 23 | 24 | genIntegerAndList :: Gen (Integer, List Integer) 25 | genIntegerAndList = P.fmap (P.fmap listh) arbitrary 26 | 27 | shrinkIntegerAndList :: (Integer, List Integer) -> [(Integer, List Integer)] 28 | shrinkIntegerAndList = P.fmap (P.fmap listh) . shrink . P.fmap hlist 29 | 30 | genTwoLists :: Gen (List Integer, List Integer) 31 | genTwoLists = (,) P.<$> genIntegerList P.<*> genIntegerList 32 | 33 | shrinkTwoLists :: (List Integer, List Integer) -> [(List Integer, List Integer)] 34 | shrinkTwoLists (a,b) = P.fmap (\(as,bs) -> (listh as, listh bs)) $ shrink (hlist a, hlist b) 35 | 36 | genThreeLists :: Gen (List Integer, List Integer, List Integer) 37 | genThreeLists = (,,) P.<$> genIntegerList P.<*> genIntegerList P.<*> genIntegerList 38 | 39 | shrinkThreeLists :: (List Integer, List Integer, List Integer) -> [(List Integer, List Integer, List Integer)] 40 | shrinkThreeLists (a,b,c) = P.fmap (\(as,bs,cs) -> (listh as, listh bs, listh cs)) $ shrink (hlist a, hlist b, hlist c) 41 | 42 | genListOfLists :: Gen (List (List Integer)) 43 | genListOfLists = P.fmap (P.fmap listh) (genList :: (Gen (List [Integer]))) 44 | 45 | shrinkListOfLists :: Arbitrary a => List (List a) -> [List (List a)] 46 | shrinkListOfLists = P.fmap (P.fmap listh). shrinkList . P.fmap hlist 47 | 48 | forAllLists :: Testable prop => (List Integer -> prop) -> Property 49 | forAllLists = forAllShrink genIntegerList shrinkList 50 | 51 | -- (List Integer) and a Bool 52 | genListAndBool :: Gen (List Integer, Bool) 53 | genListAndBool = (,) P.<$> genIntegerList P.<*> arbitrary 54 | 55 | shrinkListAndBool :: (List Integer, Bool) -> [(List Integer, Bool)] 56 | shrinkListAndBool (xs,b) = (,) P.<$> (shrinkList xs) P.<*> (shrink b) 57 | 58 | forAllListsAndBool :: Testable prop 59 | => ((List Integer, Bool) -> prop) 60 | -> Property 61 | forAllListsAndBool = 62 | forAllShrink genListAndBool shrinkListAndBool 63 | 64 | -- ListZipper Integer 65 | genListZipper :: Gen (ListZipper Integer) 66 | genListZipper = 67 | zipper P.<$> arbitrary P.<*> arbitrary P.<*> arbitrary 68 | 69 | shrinkListZipper :: ListZipper Integer -> [ListZipper Integer] 70 | shrinkListZipper (ListZipper l x r) = 71 | ListZipper P.<$> (shrinkList l) P.<*> (shrink x) P.<*> (shrinkList r) 72 | 73 | forAllListZipper :: Testable prop 74 | => (ListZipper Integer -> prop) 75 | -> Property 76 | forAllListZipper = 77 | forAllShrink genListZipper shrinkListZipper 78 | 79 | genListZipperWithInt :: Gen (ListZipper Integer, Int) 80 | genListZipperWithInt = 81 | (,) P.<$> genListZipper P.<*> arbitrary 82 | 83 | shrinkListZipperWithInt :: (ListZipper Integer, Int) -> [(ListZipper Integer, Int)] 84 | shrinkListZipperWithInt (z, i) = 85 | (,) P.<$> (shrinkListZipper z) P.<*> (shrink i) 86 | 87 | forAllListZipperWithInt :: Testable prop 88 | => ((ListZipper Integer, Int) -> prop) 89 | -> Property 90 | forAllListZipperWithInt = 91 | forAllShrink genListZipperWithInt shrinkListZipperWithInt 92 | -------------------------------------------------------------------------------- /src/Course/Monad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.Monad where 7 | 8 | import Course.Applicative 9 | import Course.Core 10 | import Course.ExactlyOne 11 | import Course.Functor 12 | import Course.List 13 | import Course.Optional 14 | import qualified Prelude as P((=<<)) 15 | 16 | -- | All instances of the `Monad` type-class must satisfy one law. This law 17 | -- is not checked by the compiler. This law is given as: 18 | -- 19 | -- * The law of associativity 20 | -- `∀f g x. g =<< (f =<< x) ≅ ((g =<<) . f) =<< x` 21 | class Applicative f => Monad f where 22 | -- Pronounced, bind. 23 | (=<<) :: 24 | (a -> f b) 25 | -> f a 26 | -> f b 27 | 28 | infixr 1 =<< 29 | 30 | -- | Binds a function on the ExactlyOne monad. 31 | -- 32 | -- >>> (\x -> ExactlyOne(x+1)) =<< ExactlyOne 2 33 | -- ExactlyOne 3 34 | instance Monad ExactlyOne where 35 | (=<<) :: 36 | (a -> ExactlyOne b) 37 | -> ExactlyOne a 38 | -> ExactlyOne b 39 | f =<< ExactlyOne a = 40 | f a 41 | 42 | -- | Binds a function on a List. 43 | -- 44 | -- >>> (\n -> n :. n :. Nil) =<< (1 :. 2 :. 3 :. Nil) 45 | -- [1,1,2,2,3,3] 46 | instance Monad List where 47 | (=<<) :: 48 | (a -> List b) 49 | -> List a 50 | -> List b 51 | (=<<) = 52 | flatMap 53 | 54 | -- | Binds a function on an Optional. 55 | -- 56 | -- >>> (\n -> Full (n + n)) =<< Full 7 57 | -- Full 14 58 | instance Monad Optional where 59 | (=<<) :: 60 | (a -> Optional b) 61 | -> Optional a 62 | -> Optional b 63 | (=<<) = 64 | bindOptional 65 | 66 | -- | Binds a function on the reader ((->) t). 67 | -- 68 | -- >>> ((*) =<< (+10)) 7 69 | -- 119 70 | instance Monad ((->) t) where 71 | (=<<) :: 72 | (a -> ((->) t b)) 73 | -> ((->) t a) 74 | -> ((->) t b) 75 | f =<< g = 76 | \x -> f (g x) x 77 | 78 | -- | Witness that all things with (=<<) and (<$>) also have (<*>). 79 | -- 80 | -- >>> ExactlyOne (+10) <**> ExactlyOne 8 81 | -- ExactlyOne 18 82 | -- 83 | -- >>> (+1) :. (*2) :. Nil <**> 1 :. 2 :. 3 :. Nil 84 | -- [2,3,4,2,4,6] 85 | -- 86 | -- >>> Full (+8) <**> Full 7 87 | -- Full 15 88 | -- 89 | -- >>> Empty <**> Full 7 90 | -- Empty 91 | -- 92 | -- >>> Full (+8) <**> Empty 93 | -- Empty 94 | -- 95 | -- >>> ((+) <**> (+10)) 3 96 | -- 16 97 | -- 98 | -- >>> ((+) <**> (+5)) 3 99 | -- 11 100 | -- 101 | -- >>> ((+) <**> (+5)) 1 102 | -- 7 103 | -- 104 | -- >>> ((*) <**> (+10)) 3 105 | -- 39 106 | -- 107 | -- >>> ((*) <**> (+2)) 3 108 | -- 15 109 | (<**>) :: 110 | Monad f => 111 | f (a -> b) 112 | -> f a 113 | -> f b 114 | f <**> a = 115 | f >>= \f' -> 116 | a >>= \a' -> 117 | pure (f' a') 118 | 119 | infixl 4 <**> 120 | 121 | -- | Flattens a combined structure to a single structure. 122 | -- 123 | -- >>> join ((1 :. 2 :. 3 :. Nil) :. (1 :. 2 :. Nil) :. Nil) 124 | -- [1,2,3,1,2] 125 | -- 126 | -- >>> join (Full Empty) 127 | -- Empty 128 | -- 129 | -- >>> join (Full (Full 7)) 130 | -- Full 7 131 | -- 132 | -- >>> join (+) 7 133 | -- 14 134 | join :: 135 | Monad f => 136 | f (f a) 137 | -> f a 138 | join = 139 | (=<<) id 140 | 141 | -- | Implement a flipped version of @(=<<)@, however, use only 142 | -- @join@ and @(<$>)@. 143 | -- Pronounced, bind flipped. 144 | -- 145 | -- >>> ((+10) >>= (*)) 7 146 | -- 119 147 | (>>=) :: 148 | Monad f => 149 | f a 150 | -> (a -> f b) 151 | -> f b 152 | a >>= f = 153 | join (f <$> a) 154 | 155 | infixl 1 >>= 156 | 157 | -- | Implement composition within the @Monad@ environment. 158 | -- Pronounced, kleisli composition. 159 | -- 160 | -- >>> ((\n -> n :. n :. Nil) <=< (\n -> n+1 :. n+2 :. Nil)) 1 161 | -- [2,2,3,3] 162 | (<=<) :: 163 | Monad f => 164 | (b -> f c) 165 | -> (a -> f b) 166 | -> a 167 | -> f c 168 | f <=< g = 169 | \x -> f =<< g x 170 | 171 | infixr 1 <=< 172 | 173 | ----------------------- 174 | -- SUPPORT LIBRARIES -- 175 | ----------------------- 176 | 177 | instance Monad IO where 178 | (=<<) = 179 | (P.=<<) 180 | -------------------------------------------------------------------------------- /test/Course/ChequeTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.ChequeTest where 6 | 7 | import Test.Tasty (TestTree, testGroup) 8 | import Test.Tasty.HUnit (testCase, (@?=)) 9 | 10 | import Course.Core 11 | import Course.Cheque (dollars) 12 | import Course.List (List (..)) 13 | 14 | test_Cheque :: TestTree 15 | test_Cheque = 16 | testGroup "Cheque" [ 17 | chequeDollarsTest 18 | ] 19 | 20 | chequeDollarsTest :: TestTree 21 | chequeDollarsTest = 22 | testGroup "jsonObject" [ 23 | testCase "empty" $ 24 | dollars "0" @?= "zero dollars and zero cents" 25 | , testCase "dollars '1'" $ 26 | dollars "1" @?= "one dollar and zero cents" 27 | , testCase "dollars '0.1'" $ 28 | dollars "0.1" @?= "zero dollars and ten cents" 29 | , testCase "dollars '1.'" $ 30 | dollars "1." @?= "one dollar and zero cents" 31 | , testCase "dollars '0.'" $ 32 | dollars "0." @?= "zero dollars and zero cents" 33 | , testCase "dollars '0.0'" $ 34 | dollars "0.0" @?= "zero dollars and zero cents" 35 | , testCase "dollars '.34'" $ 36 | dollars ".34" @?= "zero dollars and thirty-four cents" 37 | , testCase "dollars '0.3456789'" $ 38 | dollars "0.3456789" @?= "zero dollars and thirty-four cents" 39 | , testCase "dollars '1.0'" $ 40 | dollars "1.0" @?= "one dollar and zero cents" 41 | , testCase "dollars '1.01'" $ 42 | dollars "1.01" @?= "one dollar and one cent" 43 | , testCase "dollars 'a1a'" $ 44 | dollars "a1a" @?= "one dollar and zero cents" 45 | , testCase "dollars 'a1a.a0.7b'" $ 46 | dollars "a1a.a0.7b" @?= "one dollar and seven cents" 47 | , testCase "dollars '100'" $ 48 | dollars "100" @?= "one hundred dollars and zero cents" 49 | , testCase "dollars '100.0'" $ 50 | dollars "100.0" @?= "one hundred dollars and zero cents" 51 | , testCase "dollars '100.00'" $ 52 | dollars "100.00" @?= "one hundred dollars and zero cents" 53 | , testCase "dollars '100.00000'" $ 54 | dollars "100.00000" @?= "one hundred dollars and zero cents" 55 | , testCase "dollars '1000456.13'" $ 56 | dollars "1000456.13" @?= "one million four hundred and fifty-six dollars and thirteen cents" 57 | , testCase "dollars '1001456.13'" $ 58 | dollars "1001456.13" @?= "one million one thousand four hundred and fifty-six dollars and thirteen cents" 59 | , testCase "dollars '16000000456.13'" $ 60 | dollars "16000000456.13" @?= "sixteen billion four hundred and fifty-six dollars and thirteen cents" 61 | , testCase "dollars '100.45'" $ 62 | dollars "100.45" @?= "one hundred dollars and forty-five cents" 63 | , testCase "dollars '100.07'" $ 64 | dollars "100.07" @?= "one hundred dollars and seven cents" 65 | , testCase "dollars '9abc9def9ghi.jkl9mno'" $ 66 | dollars "9abc9def9ghi.jkl9mno" @?= "nine hundred and ninety-nine dollars and ninety cents" 67 | , testCase "dollars '12345.67'" $ 68 | dollars "12345.67" @?= "twelve thousand three hundred and forty-five dollars and sixty-seven cents" 69 | , testCase "dollars '456789123456789012345678901234567890123456789012345678901234567890.12'" $ 70 | dollars "456789123456789012345678901234567890123456789012345678901234567890.12" @?= "four hundred and fifty-six vigintillion seven hundred and eighty-nine novemdecillion one hundred and twenty-three octodecillion four hundred and fifty-six septendecillion seven hundred and eighty-nine sexdecillion twelve quindecillion three hundred and forty-five quattuordecillion six hundred and seventy-eight tredecillion nine hundred and one duodecillion two hundred and thirty-four undecillion five hundred and sixty-seven decillion eight hundred and ninety nonillion one hundred and twenty-three octillion four hundred and fifty-six septillion seven hundred and eighty-nine sextillion twelve quintillion three hundred and forty-five quadrillion six hundred and seventy-eight trillion nine hundred and one billion two hundred and thirty-four million five hundred and sixty-seven thousand eight hundred and ninety dollars and twelve cents" 71 | ] 72 | -------------------------------------------------------------------------------- /projects/TicTacToe/TicTacToe.markdown: -------------------------------------------------------------------------------- 1 | TicTacToe 2 | ========= 3 | 4 | The goal is to write an API for the tic-tac-toe game. An API user, should be able to play a game of tic-tac-toe using this API, but importantly, it should be impossible for the API user to break the rules of the game. Specifically, if an attempt is made to break a rule, the API should reject the program. This is often done by way of a *compile-time type error*. 5 | 6 | It is strongly advised that functional programming techniques are used to achieve the goal. This is because ensuring that the API adheres to the rules of tic-tac-toe, while rejecting a program otherwise, is difficult otherwise. No specific programming language is prescribed. 7 | 8 | The following API functions should exist. By removing the need for some of these functions, the challenge becomes significantly easier. Removing some or all optional API functions is an advised path for someone who is looking to make the challenge easier. 9 | 10 | * `move`: takes a tic-tac-toe board and position and moves to that position (if not occupied) returning a new board. This function can only be called on a board that is empty or in-play. Calling `move` on a game board that is finished is a *compile-time type error*. 11 | 12 | *(optional)* If fewer than 5 moves have been played, then this guarantees that the game is still in play, and so calling `move` will never produce a type-error in this case. 13 | 14 | * `whoWon`: takes a tic-tac-toe board and returns the player that won the game (or a draw if neither). This function can only be called on a board that is finished. Calling `whoWon` on a game board that is empty or in-play is a *compile-time type error*. As an optional consideration, `whoWon` should never be a draw if fewer than nine moves have been played. In the case that the game is completed, but fewer than nine moves have been played, return a value that can only be one of two possibilities (the winner) and never a draw. 15 | 16 | * `playerAt`: takes a tic-tac-toe board and position and returns the (possible) player at a given position. This function works on any type of board. 17 | 18 | * `takeBack` *(optional)*: takes either a finished board or a board in-play that has had at least one move and returns a board in-play. It is a compile-time type error to call this function on an empty board. 19 | 20 | * `isDraw` *(optional)* if called on a game with fewer than 9 moves, a compile-time type-error results. 21 | 22 | * Other API functions that might be considered useful for general API use. Ensure that it is not possible to violate the game rules of tic-tac-toe. These functions can often be determined by also writing an interactive console application that uses the API -- other useful functions are likely to arise. 23 | 24 | You should write automated tests for your API. For example, the following universally quantified property holds true: 25 | 26 | `forall Board b. forall Position p. such that (not (positionIsOccupied 27 | p b)). takeBack(move(p, b)) == b` 28 | 29 | You should encode this property in an automated specification test. For Scala, use ScalaCheck. For Haskell, QuickCheck. For Java, consider [Functional Java](http://functionaljava.org/). For .NET, use [FsCheck](https://github.com/fsharp/FsCheck). For other languages, you may need to search around. 30 | 31 | Haskell-specific 32 | ---------------- 33 | 34 | If you choose to use Haskell, also take advantage of its tooling: 35 | 36 | * Build with CABAL 37 | * Include a `.ghci` file for convenience when developing 38 | * https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/ghci-dot-files.html 39 | * API documented using Haddock 40 | * [http://www.haskell.org/haddock/doc/html/index.html](http://www.haskell.org/haddock/doc/html/index.html) 41 | * Code style examined using hlint 42 | * `cabal install hlint` 43 | * Produce a report (`--report`) 44 | * [http://community.haskell.org/~ndm/darcs/hlint/hlint.htm](http://community.haskell.org/~ndm/darcs/hlint/hlint.htm) 45 | * Use hoogle and hayoo to find library functions 46 | * [http://haskell.org/hoogle/](http://haskell.org/hoogle/) 47 | * [http://holumbus.fh-wedel.de/hayoo/hayoo.html](http://holumbus.fh-wedel.de/hayoo/hayoo.html) 48 | 49 | 50 | Extra-curricular 51 | ---------------- 52 | * Write an opponent that never loses 53 | * Write an opponent with easy, medium, hard difficulty levels 54 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/WithPosition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE MultiParamTypeClasses #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | module TicTacToe.WithPosition( 6 | WithPosition((-->)) 7 | ) where 8 | 9 | import Control.Category((.)) 10 | import Control.Monad((>>=)) 11 | import TicTacToe.Position(Position) 12 | import TicTacToe.MoveOr(Move2Or(Move2Or), Move3Or(Move3Or), Move4Or(Move4Or), Move5Or(Move5Or), Move6Or(Move6Or), Move7Or(Move7Or), Move8Or(Move8Or), Move9Or(Move9Or), MoveOr6Or(MoveOr6OrWin5, MoveOr6Or), MoveOr7Or(MoveOr7OrWin5, MoveOr7OrWin6, MoveOr7Or), MoveOr8Or(MoveOr8OrWin5, MoveOr8OrWin6, MoveOr8OrWin7, MoveOr8Or), MoveOr9Or(MoveOr9OrWin5, MoveOr9OrWin6, MoveOr9OrWin7, MoveOr9OrWin8, MoveOr9Or)) 13 | import Control.Lens(( # )) 14 | import TicTacToe.Move(Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, start, move2, move3, move4, move5, move6, move7, move8, move9) 15 | import TicTacToe.OccupiedOr(OccupiedOr(Occupied, Or), AsOccupiedOr(_OccupiedOr)) 16 | import TicTacToe.AsOr(AsOr(_Or)) 17 | import TicTacToe.WinOccupiedOr(WinOccupiedOr(IsOccupiedOr, Win)) 18 | 19 | class WithPosition f g | f -> g where 20 | (-->) :: 21 | Position 22 | -> f 23 | -> g 24 | 25 | infixr 6 --> 26 | 27 | instance WithPosition () Move1 where 28 | p --> () = 29 | start p 30 | 31 | instance WithPosition Move1 Move2Or where 32 | p --> m = 33 | Move2Or (move2 p m) 34 | 35 | instance WithPosition Move2Or Move3Or where 36 | p --> Move2Or m = 37 | Move3Or (m >>= move3 p) 38 | 39 | instance WithPosition Move2 Move3Or where 40 | (-->) p = 41 | (-->) p . Move2Or . (#) _Or 42 | 43 | instance WithPosition Move3Or Move4Or where 44 | p --> Move3Or m = 45 | Move4Or (m >>= move4 p) 46 | 47 | instance WithPosition Move3 Move4Or where 48 | (-->) p = 49 | (-->) p . Move3Or . (#) _Or 50 | 51 | instance WithPosition Move4Or Move5Or where 52 | p --> Move4Or m = 53 | Move5Or ((_OccupiedOr # m) >>= move5 p) 54 | 55 | instance WithPosition Move4 Move5Or where 56 | (-->) p = 57 | (-->) p . Move4Or . (#) _Or 58 | 59 | instance WithPosition Move5Or MoveOr6Or where 60 | _ --> Move5Or (Win w) = 61 | MoveOr6OrWin5 w 62 | _ --> Move5Or (IsOccupiedOr Occupied) = 63 | MoveOr6Or (Move6Or (IsOccupiedOr Occupied)) 64 | p --> Move5Or (IsOccupiedOr (Or m)) = 65 | MoveOr6Or (p --> m) 66 | 67 | instance WithPosition Move5 Move6Or where 68 | p --> m = 69 | Move6Or (move6 p m) 70 | 71 | instance WithPosition Move6 Move7Or where 72 | p --> m = 73 | Move7Or (move7 p m) 74 | 75 | instance WithPosition Move6Or MoveOr7Or where 76 | _ --> Move6Or (Win w) = 77 | MoveOr7OrWin6 w 78 | _ --> Move6Or (IsOccupiedOr Occupied) = 79 | MoveOr7Or (Move7Or (IsOccupiedOr Occupied)) 80 | p --> Move6Or (IsOccupiedOr (Or m)) = 81 | MoveOr7Or (p --> m) 82 | 83 | instance WithPosition MoveOr6Or MoveOr7Or where 84 | _ --> MoveOr6OrWin5 w = 85 | MoveOr7OrWin5 w 86 | p --> MoveOr6Or m = 87 | p --> m 88 | 89 | instance WithPosition Move7 Move8Or where 90 | p --> m = 91 | Move8Or (move8 p m) 92 | 93 | instance WithPosition Move7Or MoveOr8Or where 94 | _ --> Move7Or (Win w) = 95 | MoveOr8OrWin7 w 96 | _ --> Move7Or (IsOccupiedOr Occupied) = 97 | MoveOr8Or (Move8Or (IsOccupiedOr Occupied)) 98 | p --> Move7Or (IsOccupiedOr (Or m)) = 99 | MoveOr8Or (p --> m) 100 | 101 | instance WithPosition MoveOr7Or MoveOr8Or where 102 | _ --> MoveOr7OrWin5 w = 103 | MoveOr8OrWin5 w 104 | _ --> MoveOr7OrWin6 w = 105 | MoveOr8OrWin6 w 106 | p --> MoveOr7Or m = 107 | p --> m 108 | 109 | instance WithPosition Move8 Move9Or where 110 | p --> m = 111 | Move9Or (move9 p m) 112 | 113 | instance WithPosition Move8Or MoveOr9Or where 114 | _ --> Move8Or (Win w) = 115 | MoveOr9OrWin8 w 116 | _ --> Move8Or (IsOccupiedOr Occupied) = 117 | MoveOr9Or (Move9Or (IsOccupiedOr Occupied)) 118 | p --> Move8Or (IsOccupiedOr (Or m)) = 119 | MoveOr9Or (p --> m) 120 | 121 | instance WithPosition MoveOr8Or MoveOr9Or where 122 | _ --> MoveOr8OrWin5 w = 123 | MoveOr9OrWin5 w 124 | _ --> MoveOr8OrWin6 w = 125 | MoveOr9OrWin6 w 126 | _ --> MoveOr8OrWin7 w = 127 | MoveOr9OrWin7 w 128 | p --> MoveOr8Or m = 129 | p --> m 130 | -------------------------------------------------------------------------------- /test/Course/StateTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | 5 | module Course.StateTest where 6 | 7 | import Data.List (nub) 8 | import qualified Prelude as P ((++)) 9 | 10 | import Test.QuickCheck.Function (Fun (..)) 11 | import Test.Tasty (TestTree, testGroup) 12 | import Test.Tasty.HUnit (testCase, (@?=)) 13 | import Test.Tasty.QuickCheck (testProperty) 14 | 15 | import Course.Applicative (pure, (<*>)) 16 | import Course.Core 17 | import Course.Functor ((<$>)) 18 | import Course.List (List (..), filter, flatMap, hlist, 19 | length, listh, span, (++)) 20 | import Course.Gens (forAllLists) 21 | import Course.Monad 22 | import Course.Optional (Optional (..)) 23 | import Course.State (State (..), distinct, eval, exec, 24 | findM, firstRepeat, get, isHappy, 25 | put, put, runState) 26 | 27 | test_State :: TestTree 28 | test_State = 29 | testGroup "State" [ 30 | execTest 31 | , evalTest 32 | , getTest 33 | , putTest 34 | , functorTest 35 | , applicativeTest 36 | , monadTest 37 | , findMTest 38 | , firstRepeatTest 39 | , distinctTest 40 | , isHappyTest 41 | ] 42 | 43 | execTest :: TestTree 44 | execTest = 45 | testProperty "exec" $ 46 | \(Fun _ f :: Fun Integer (Integer, Integer)) s -> exec (State f) s == snd (runState (State f) s) 47 | 48 | evalTest :: TestTree 49 | evalTest = 50 | testProperty "eval" $ 51 | \(Fun _ f :: Fun Integer (Integer, Integer)) s -> eval (State f) s == fst (runState (State f) s) 52 | 53 | getTest :: TestTree 54 | getTest = 55 | testCase "get" $ runState get 0 @?= (0,0) 56 | 57 | putTest :: TestTree 58 | putTest = 59 | testCase "put" $ runState (put 1) 0 @?= ((),1) 60 | 61 | functorTest :: TestTree 62 | functorTest = 63 | testCase "(<$>)" $ 64 | runState ((+1) <$> State (\s -> (9, s * 2))) 3 @?= (10,6) 65 | 66 | applicativeTest :: TestTree 67 | applicativeTest = 68 | testGroup "Applicative" [ 69 | testCase "pure" $ runState (pure 2) 0 @?= (2,0) 70 | , testCase "<*>" $ runState (pure (+1) <*> pure 0) 0 @?= (1,0) 71 | , testCase "complicated <*>" $ 72 | let state = State (\s -> ((+3), s P.++ ["apple"])) <*> State (\s -> (7, s P.++ ["banana"])) 73 | in runState state [] @?= (10,["apple","banana"]) 74 | ] 75 | 76 | monadTest :: TestTree 77 | monadTest = 78 | testGroup "Monad" [ 79 | testCase "(=<<)" $ 80 | runState ((const $ put 2) =<< put 1) 0 @?= ((),2) 81 | , testCase "(>>=)" $ 82 | let modify f = State (\s -> ((), f s)) 83 | in runState (modify (+1) >>= \() -> modify (*2)) 7 @?= ((),16) 84 | ] 85 | 86 | findMTest :: TestTree 87 | findMTest = 88 | testGroup "findM" [ 89 | testCase "find 'c' in 'a'..'h'" $ 90 | let p x = (\s -> (const $ pure (x == 'c')) =<< put (1+s)) =<< get 91 | in runState (findM p $ listh ['a'..'h']) 0 @?= (Full 'c',3) 92 | , testCase "find 'i' in 'a'..'h'" $ 93 | let p x = (\s -> (const $ pure (x == 'i')) =<< put (1+s)) =<< get 94 | in runState (findM p $ listh ['a'..'h']) 0 @?= (Empty,8) 95 | ] 96 | 97 | firstRepeatTest :: TestTree 98 | firstRepeatTest = 99 | testGroup "firstRepeat" [ 100 | testProperty "finds repeats" $ forAllLists (\xs -> 101 | case firstRepeat xs of 102 | Empty -> 103 | let xs' = hlist xs 104 | in nub xs' == xs' 105 | Full x -> length (filter (== x) xs) > 1 106 | ) 107 | , testProperty "" $ forAllLists (\xs -> 108 | case firstRepeat xs of 109 | Empty -> True 110 | Full x -> 111 | let (l, (rx :. rs)) = span (/= x) xs 112 | in let (l2, _) = span (/= x) rs 113 | in let l3 = hlist (l ++ (rx :. Nil) ++ l2) 114 | in nub l3 == l3 115 | ) 116 | ] 117 | 118 | distinctTest :: TestTree 119 | distinctTest = 120 | testGroup "distinct" [ 121 | testProperty "No repeats after distinct" $ 122 | forAllLists (\xs -> firstRepeat (distinct xs) == Empty) 123 | , testProperty "" $ 124 | forAllLists (\xs -> distinct xs == distinct (flatMap (\x -> x :. x :. Nil) xs)) 125 | ] 126 | 127 | isHappyTest :: TestTree 128 | isHappyTest = 129 | testGroup "isHappy" [ 130 | testCase "4" $ isHappy 4 @?= False 131 | , testCase "7" $ isHappy 7 @?= True 132 | , testCase "42" $ isHappy 42 @?= False 133 | , testCase "44" $ isHappy 44 @?= True 134 | ] 135 | -------------------------------------------------------------------------------- /course.cabal: -------------------------------------------------------------------------------- 1 | name: course 2 | version: 0.1.4 3 | license: BSD3 4 | license-file: etc/LICENCE 5 | author: Tony Morris 6 | Mark Hibberd 7 | Ben Sinclair 8 | James Earl Douglas 9 | Eric Torreborre 10 | maintainer: Tony Morris 11 | copyright: Copyright (C) 2010-2013 Tony Morris 12 | Copyright (C) 2012-2015 National ICT Australia Limited 13 | Copyright (C) 2012 James Earl Douglas 14 | Copyright (C) 2012 Ben Sinclair 15 | Copyright (C) 2016-2017 Data61 16 | synopsis: Source code for a functional programming course 17 | category: Education 18 | description: Source code for a course in functional programming using Haskell 19 | homepage: https://github.com/data61/fp-course 20 | bug-reports: https://github.com/data61/fp-course/issues 21 | cabal-version: >= 1.10 22 | build-type: Simple 23 | tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 24 | extra-source-files: etc/CONTRIBUTORS, 25 | changelog 26 | 27 | source-repository head 28 | type: git 29 | location: git@github.com:data61/fp-course.git 30 | 31 | library 32 | default-language: Haskell2010 33 | 34 | build-depends: base < 5 && >= 4 35 | , containers >= 0.4 36 | , array >= 0.4 37 | 38 | ghc-options: -Wall 39 | -fwarn-incomplete-uni-patterns 40 | -fno-warn-unused-binds 41 | -fno-warn-unused-do-bind 42 | -fno-warn-unused-imports 43 | -fno-warn-type-defaults 44 | -ferror-spans 45 | 46 | default-extensions: NoImplicitPrelude 47 | ScopedTypeVariables 48 | InstanceSigs 49 | 50 | hs-source-dirs: src 51 | 52 | exposed-modules: Course 53 | Course.Anagrams 54 | Course.Applicative 55 | Course.Alternative 56 | Course.Cheque 57 | Course.Comonad 58 | Course.Compose 59 | Course.Core 60 | Course.ExactlyOne 61 | Course.Extend 62 | Course.FastAnagrams 63 | Course.FileIO 64 | Course.Functor 65 | Course.Interactive 66 | Course.JsonParser 67 | Course.JsonValue 68 | Course.List 69 | Course.ListZipper 70 | Course.Monad 71 | Course.MonadTutorial 72 | Course.MoreParser 73 | Course.Optional 74 | Course.Parser 75 | Course.Person 76 | Course.State 77 | Course.StateT 78 | Course.Traversable 79 | Course.Validation 80 | 81 | 82 | test-suite tasty 83 | type: 84 | exitcode-stdio-1.0 85 | 86 | main-is: 87 | TastyLoader.hs 88 | other-modules: 89 | Course.ApplicativeTest 90 | Course.ChequeTest 91 | Course.ComonadTest 92 | Course.ExtendTest 93 | Course.FunctorTest 94 | Course.Gens 95 | Course.JsonParserTest 96 | Course.ListTest 97 | Course.ListZipperTest 98 | Course.MonadTest 99 | Course.MoreParserTest 100 | Course.OptionalTest 101 | Course.ParserTest 102 | Course.StateTest 103 | Course.StateTTest 104 | Course.TraversableTest 105 | Course.ValidationTest 106 | 107 | default-language: 108 | Haskell2010 109 | 110 | build-depends: 111 | base < 5 && >= 3 112 | , containers >= 0.4 113 | , course 114 | , HUnit >= 1.5 115 | , QuickCheck >= 2.9 116 | , tasty >= 1 117 | , tasty-hunit >= 0.9 118 | , tasty-quickcheck >= 0.8 119 | 120 | ghc-options: 121 | -Wall 122 | -threaded 123 | 124 | hs-source-dirs: 125 | test 126 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/Chat/Loop.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.Chat.Loop where 2 | 3 | import Prelude hiding (mapM_, catch) 4 | import Network(PortID(..), sClose, withSocketsDo, listenOn) 5 | import System.IO(BufferMode(..)) 6 | import Data.IORef(IORef, newIORef, readIORef) 7 | import Data.Foldable(Foldable, mapM_) 8 | import Control.Applicative(Applicative, pure) 9 | import Control.Concurrent(forkIO) 10 | import Control.Exception(finally, try, catch, Exception) 11 | import Control.Monad(forever) 12 | import Control.Monad.Trans(MonadTrans(..), MonadIO(..)) 13 | 14 | import Network.Server.Common.Accept 15 | import Network.Server.Common.HandleLens 16 | import Network.Server.Common.Lens 17 | import Network.Server.Common.Line 18 | import Network.Server.Common.Env 19 | import Network.Server.Common.Ref 20 | import Data.Set(Set) 21 | import qualified Data.Set as S 22 | 23 | data Loop v f a = 24 | Loop (Env v -> f a) 25 | 26 | type IOLoop v a = 27 | Loop v IO a 28 | 29 | type IORefLoop v a = 30 | IOLoop (IORef v) a 31 | 32 | instance Functor f => Functor (Loop v f) where 33 | fmap f (Loop k) = 34 | Loop (fmap f . k) 35 | 36 | instance Applicative f => Applicative (Loop v f) where 37 | pure = 38 | Loop . pure . pure 39 | Loop f <*> Loop x = 40 | Loop (\a -> f a <*> x a) 41 | 42 | instance Monad f => Monad (Loop v f) where 43 | return = 44 | Loop . return . return 45 | Loop k >>= f = 46 | Loop (\v -> k v >>= \a -> 47 | let Loop l = f a 48 | in l v) 49 | 50 | instance MonadTrans (Loop v) where 51 | lift = 52 | Loop . const 53 | 54 | instance MonadIO f => MonadIO (Loop v f) where 55 | liftIO = 56 | lift . liftIO 57 | 58 | etry :: 59 | Exception e => 60 | (Env v -> IO a) 61 | -> IOLoop v (Either e a) 62 | etry k = 63 | Loop $ try . k 64 | 65 | server :: 66 | IO w -- server initialise 67 | -> (w -> IO v) -- client accepted (pre) 68 | -> IOLoop v () -- per-client 69 | -> IO a 70 | server i r (Loop f) = 71 | let hand s w c = forever $ 72 | do q <- accept' s 73 | lSetBuffering q NoBuffering 74 | _ <- atomicModifyIORef_ c (S.insert (refL `getL` q)) 75 | x <- r w 76 | forkIO (f (Env q c x)) 77 | in withSocketsDo $ do 78 | s <- listenOn (PortNumber 6060) 79 | w <- i 80 | c <- newIORef S.empty 81 | hand s w c `finally` sClose s 82 | 83 | allClients :: IOLoop v (Set Ref) 84 | allClients = Loop $ \env -> readIORef (clientsL `getL` env) 85 | 86 | perClient :: 87 | IOLoop v x -- client accepted (post) 88 | -> (String -> IOLoop v a) -- read line from client 89 | -> IOLoop v () 90 | perClient = 91 | error "todo" 92 | 93 | loop :: 94 | IO w -- server initialise 95 | -> (w -> IO v) -- client accepted (pre) 96 | -> IOLoop v x -- client accepted (post) 97 | -> (String -> IOLoop v w) -- read line from client 98 | -> IO a 99 | loop i r q f = 100 | server i r (perClient q f) 101 | 102 | iorefServer :: 103 | v -- server initialise 104 | -> IORefLoop v () -- per-client 105 | -> IO a 106 | iorefServer x = 107 | server (newIORef x) return 108 | 109 | iorefLoop :: 110 | v -- server initialise 111 | -> IORefLoop v x -- client accepted (post) 112 | -> (String -> IORefLoop v w) -- read line from client 113 | -> IO a 114 | iorefLoop x q f = 115 | iorefServer x (perClient q f) 116 | 117 | pPutStrLn :: 118 | String 119 | -> IOLoop v () 120 | pPutStrLn s = 121 | Loop (`lPutStrLn` s) 122 | 123 | (!) :: 124 | Foldable t => 125 | IOLoop v (t Ref) 126 | -> String 127 | -> IOLoop v () 128 | clients ! msg = 129 | clients >>= purgeClients (\y -> liftIO (lPutStrLn y msg)) 130 | 131 | infixl 2 ! 132 | 133 | purgeClients :: 134 | Foldable t => 135 | (Ref -> IOLoop v ()) 136 | -> t Ref 137 | -> IOLoop v () 138 | purgeClients a = 139 | mapM_ (\y -> 140 | ecatch (a y) 141 | (\x -> do _ <- modifyClients (S.delete y) 142 | xprint x) 143 | ) 144 | 145 | readEnv :: 146 | Applicative f => 147 | Loop v f (Env v) 148 | readEnv = 149 | Loop $ pure 150 | 151 | readEnvval :: 152 | Applicative f => 153 | Loop v f v 154 | readEnvval = 155 | fmap (envvalL `getL`) readEnv 156 | 157 | readIOEnvval :: 158 | IORefLoop a a 159 | readIOEnvval = 160 | Loop $ \env -> 161 | readIORef (envvalL `getL` env) 162 | 163 | allClientsButThis :: 164 | IOLoop v (Set Ref) 165 | allClientsButThis = 166 | Loop $ \env -> 167 | fmap (S.delete ((acceptL .@ refL) `getL` env)) (readIORef (clientsL `getL` env)) 168 | 169 | -- Control.Monad.CatchIO 170 | ecatch :: 171 | Exception e => 172 | IOLoop v a 173 | -> (e -> IOLoop v a) 174 | -> IOLoop v a 175 | ecatch (Loop k) f = 176 | Loop $ \env -> k env `catch` (\e -> let Loop l = f e in l env) 177 | 178 | modifyClients :: 179 | (Set Ref -> Set Ref) 180 | -> IOLoop v (Set Ref) 181 | modifyClients f = 182 | Loop $ \env -> 183 | atomicModifyIORef_ (clientsL `getL` env) f 184 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Position.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | 6 | module TicTacToe.Position( 7 | Position(P1, P2, P3, P4, P5, P6, P7, P8, P9) 8 | , AsPosition(_Position) 9 | , magic 10 | , positionIndex 11 | , positionPlayer 12 | , whoseTurn 13 | , IndexingN(IndexingN, runIndexingN) 14 | ) where 15 | 16 | import Control.Applicative(Applicative((<*>), pure), Const) 17 | import Control.Category(id, (.)) 18 | import Control.Lens(Iso', Optic', Choice, Indexable(indexed), (^.), ( # ), iso, prism', elemIndexOf, lengthOf, _2) 19 | import Data.Char(Char) 20 | import Data.Eq(Eq) 21 | import Data.Functor(Functor(fmap)) 22 | import Data.Int(Int) 23 | import Data.Maybe(Maybe(Just, Nothing)) 24 | import Data.Monoid(First, Endo) 25 | import Data.Ord(Ord) 26 | import Prelude(Show, Num((+)), seq, even) 27 | import TicTacToe.Player(Player(X), _Player, playerswap) 28 | 29 | data Position = 30 | P1 31 | | P2 32 | | P3 33 | | P4 34 | | P5 35 | | P6 36 | | P7 37 | | P8 38 | | P9 39 | deriving (Eq, Ord, Show) 40 | 41 | magic :: 42 | Iso' 43 | Position 44 | Position 45 | magic = 46 | iso 47 | (\p -> case p of 48 | P1 -> P2 49 | P2 -> P9 50 | P3 -> P4 51 | P4 -> P7 52 | P5 -> P5 53 | P6 -> P3 54 | P7 -> P6 55 | P8 -> P1 56 | P9 -> P8) 57 | (\p -> case p of 58 | P1 -> P8 59 | P2 -> P1 60 | P3 -> P6 61 | P4 -> P3 62 | P5 -> P5 63 | P6 -> P7 64 | P7 -> P4 65 | P8 -> P9 66 | P9 -> P2) 67 | 68 | class AsPosition p f s where 69 | _Position :: 70 | Optic' p f s Position 71 | 72 | instance AsPosition p f Position where 73 | _Position = 74 | id 75 | 76 | instance (p ~ (->), Applicative f) => AsPosition p f () where 77 | _Position _ () = 78 | pure () 79 | 80 | instance (Choice p, Applicative f) => AsPosition p f Int where 81 | _Position = 82 | prism' 83 | (\p -> case p of 84 | P1 -> 1 85 | P2 -> 2 86 | P3 -> 3 87 | P4 -> 4 88 | P5 -> 5 89 | P6 -> 6 90 | P7 -> 7 91 | P8 -> 8 92 | P9 -> 9) 93 | (\p -> case p of 94 | 1 -> Just P1 95 | 2 -> Just P2 96 | 3 -> Just P3 97 | 4 -> Just P4 98 | 5 -> Just P5 99 | 6 -> Just P6 100 | 7 -> Just P7 101 | 8 -> Just P8 102 | 9 -> Just P9 103 | _ -> Nothing) 104 | 105 | instance (Choice p, Applicative f) => AsPosition p f Char where 106 | _Position = 107 | prism' 108 | (\p -> case p of 109 | P1 -> '1' 110 | P2 -> '2' 111 | P3 -> '3' 112 | P4 -> '4' 113 | P5 -> '5' 114 | P6 -> '6' 115 | P7 -> '7' 116 | P8 -> '8' 117 | P9 -> '9') 118 | (\p -> case p of 119 | '1' -> Just P1 120 | '2' -> Just P2 121 | '3' -> Just P3 122 | '4' -> Just P4 123 | '5' -> Just P5 124 | '6' -> Just P6 125 | '7' -> Just P7 126 | '8' -> Just P8 127 | '9' -> Just P9 128 | _ -> Nothing) 129 | 130 | newtype IndexingN n f a = 131 | IndexingN { 132 | runIndexingN :: n -> (n, f a) 133 | } 134 | 135 | instance Functor f => Functor (IndexingN n f) where 136 | fmap f (IndexingN m) = 137 | IndexingN (fmap (fmap f) . m) 138 | 139 | instance Applicative f => Applicative (IndexingN n f) where 140 | pure x = 141 | IndexingN (\i -> (i, pure x)) 142 | IndexingN f <*> IndexingN a = 143 | IndexingN (\i -> let (o, g) = f i 144 | ~(p, b) = a o 145 | in (p, g <*> b)) 146 | 147 | indexingN :: 148 | Indexable i p => 149 | a 150 | -> (i -> i) 151 | -> ((d -> IndexingN i g c) -> t -> IndexingN a f b) 152 | -> p d (g c) 153 | -> t 154 | -> f b 155 | indexingN x k l iafb s = 156 | runIndexingN (l (\a -> IndexingN (\i -> i `seq` (k i, indexed iafb i a))) s) x ^. _2 157 | 158 | positionIndex :: 159 | (Num i, AsPosition (->) (IndexingN i (Const (First i))) a) => 160 | Position 161 | -> a 162 | -> Maybe i 163 | positionIndex = 164 | elemIndexOf (indexingN 0 (+1) _Position) 165 | 166 | positionPlayer :: 167 | AsPosition (->) (IndexingN Player (Const (First Player))) a => 168 | Position 169 | -> a 170 | -> Maybe Player 171 | positionPlayer = 172 | elemIndexOf (indexingN X (playerswap #) _Position) 173 | 174 | whoseTurn :: 175 | AsPosition (->) (Const (Endo (Endo Int))) g => 176 | g 177 | -> Player 178 | whoseTurn x = 179 | even (lengthOf _Position x) ^. _Player 180 | -------------------------------------------------------------------------------- /test/Course/TraversableTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | 4 | module Course.TraversableTest where 5 | 6 | import Test.Tasty (TestTree, testGroup) 7 | import Test.Tasty.HUnit (testCase, (@?=)) 8 | 9 | import Course.Compose (Compose (..)) 10 | import Course.Core 11 | import Course.ExactlyOne (ExactlyOne (..)) 12 | import Course.Functor 13 | import Course.List (List (..), listh) 14 | import Course.Optional (Optional (..)) 15 | import Course.Traversable 16 | 17 | test_Traversable :: TestTree 18 | test_Traversable = 19 | testGroup "Traversable" [ 20 | listTest 21 | , exactlyOneTest 22 | , optionalTest 23 | , sequenceATest 24 | , composeTest 25 | , productFunctorTest 26 | , productTraversableTest 27 | , coProductFunctorTest 28 | , coProductTraversableTest 29 | ] 30 | 31 | listTest :: TestTree 32 | listTest = 33 | testGroup "listTest" [ 34 | testCase "traverse on empty list" $ 35 | traverse (\a -> Full (a * 2)) (Nil :: List Int) @?= Full Nil 36 | , testCase "traverse on non-empty list" $ 37 | traverse (\a -> Full (a * 2)) (listh [1, 2, 3]) @?= Full (listh [2, 4, 6]) 38 | ] 39 | 40 | exactlyOneTest :: TestTree 41 | exactlyOneTest = 42 | testGroup "exactlyOneTest" [ 43 | testCase "traverse on ExactlyOne" $ 44 | traverse (\a -> Full (a * 2)) (ExactlyOne 3) @?= Full (ExactlyOne 6) 45 | ] 46 | 47 | optionalTest :: TestTree 48 | optionalTest = 49 | testGroup "optionalTest" [ 50 | testCase "traverse on Empty" $ 51 | traverse (\a -> ExactlyOne (a * 2)) Empty @?= ExactlyOne Empty 52 | , testCase "traverse on Full" $ 53 | traverse (\a -> ExactlyOne (a * 2)) (Full 5) @?= ExactlyOne (Full 10) 54 | ] 55 | 56 | sequenceATest :: TestTree 57 | sequenceATest = 58 | testGroup "sequenceATest" [ 59 | testCase "on List over ExactlyOne" $ 60 | sequenceA (listh [ExactlyOne 7, ExactlyOne 8, ExactlyOne 9]) @?= ExactlyOne (listh [7,8,9]) 61 | , testCase "on Optional over ExactlyOne" $ 62 | sequenceA (Full (ExactlyOne 7)) @?= ExactlyOne (Full 7) 63 | , testCase "on Optional over function" $ 64 | sequenceA (Full (*10)) 6 @?= Full 60 65 | ] 66 | 67 | composeTest :: TestTree 68 | composeTest = 69 | testGroup "composeTest" [ 70 | testCase "traverse on Compose Optional List Int" $ 71 | traverse (\a -> ExactlyOne (a * 2)) cfli @?= ExactlyOne traversedCfli 72 | , testCase "traverse on Compose List ExactlyOne Int" $ 73 | traverse (\a -> Full (a * 2)) clei @?= Full traversedClei 74 | ] 75 | where 76 | cfli = Compose fullListOfInts 77 | traversedCfli = Compose $ (*2) `fmap2` fullListOfInts 78 | clei = Compose listOfExactlyOnes 79 | traversedClei = Compose $ (*2) `fmap2` listOfExactlyOnes 80 | fullListOfInts = Full (listh [1, 2, 3]) 81 | listOfExactlyOnes = listh [ExactlyOne 1, ExactlyOne 2, ExactlyOne 3] 82 | fmap2 f = ((f <$>) <$>) 83 | 84 | productFunctorTest :: TestTree 85 | productFunctorTest = 86 | testGroup "productFunctorTest" [ 87 | testCase "fmap on Product Optional List Int" $ 88 | (*2) <$> Product (Full 4) listOfInts @?= Product (Full 8) ((*2) <$> listOfInts) 89 | , testCase "fmap on Product ExactlyOne Optional Int" $ 90 | (*2) <$> Product (ExactlyOne 4) Empty @?= Product (ExactlyOne 8) Empty 91 | ] 92 | where 93 | listOfInts = listh [1, 2, 3] 94 | 95 | productTraversableTest :: TestTree 96 | productTraversableTest = 97 | testGroup "productTraversableTest" [ 98 | testCase "traverse on Product Optional List Int" $ 99 | traverse (\a -> ExactlyOne (a*2)) product @?= ExactlyOne productTimesTwo 100 | ] 101 | where 102 | listOfInts = listh [1, 2, 3] 103 | product = Product (Full 4) listOfInts 104 | productTimesTwo = Product (Full 8) ((*2) <$> listOfInts) 105 | 106 | coProductFunctorTest :: TestTree 107 | coProductFunctorTest = 108 | testGroup "coProductFunctorTest" [ 109 | testCase "fmap on InL Optional Int" $ 110 | (*2) <$> inL @?= inLTimesTwo 111 | , testCase "fmap on InR ExactlyOne Int" $ 112 | (*2) <$> inR @?= inRTimesTwo 113 | ] 114 | where 115 | inL, inLTimesTwo :: Coproduct Optional List Int 116 | inL = InL (Full 4) 117 | inLTimesTwo = InL (Full 8) 118 | inR, inRTimesTwo :: Coproduct Optional List Int 119 | inR = InR listOfInts 120 | inRTimesTwo = InR ((*2) <$> listOfInts) 121 | listOfInts = listh [1, 2, 3] 122 | 123 | coProductTraversableTest :: TestTree 124 | coProductTraversableTest = 125 | testGroup "coProductTraversableTest" [ 126 | testCase "traverse on InL Optional Int" $ 127 | traverse (\a -> ExactlyOne (a*2)) inL @?= ExactlyOne inLTimesTwo 128 | , testCase "traverse on InR List Int" $ 129 | traverse (\a -> Full (a*2)) inR @?= Full inRTimesTwo 130 | ] 131 | where 132 | inL, inLTimesTwo :: Coproduct Optional List Int 133 | inL = InL (Full 4) 134 | inLTimesTwo = InL (Full 8) 135 | inR, inRTimesTwo :: Coproduct Optional List Int 136 | inR = InR listOfInts 137 | inRTimesTwo = InR ((*2) <$> listOfInts) 138 | listOfInts = listh [1, 2, 3] 139 | 140 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Data/TicTacToe.hs: -------------------------------------------------------------------------------- 1 | module Data.TicTacToe where 2 | 3 | import Prelude hiding (any, all, mapM, concat) 4 | import qualified GHC.OldList as L 5 | import Test.QuickCheck 6 | import Data.Map (Map, singleton) 7 | import qualified Data.Map as M 8 | import Data.Traversable 9 | import Data.Foldable hiding (foldr) 10 | import Data.List(intercalate) 11 | 12 | 13 | data Player = 14 | Naught 15 | | Cross 16 | deriving (Ord, Eq) 17 | 18 | instance Show Player where 19 | show Naught = 20 | "O" 21 | show Cross = 22 | "X" 23 | 24 | data EmptyBoard = 25 | EmptyBoard 26 | deriving (Eq, Show) 27 | 28 | data Board = 29 | Board (Map Position Player) [(Position, Player)] 30 | deriving Eq 31 | 32 | data FinishedBoard = 33 | FinishedBoard (Maybe Player) Board 34 | deriving Eq 35 | 36 | instance Show FinishedBoard where 37 | show (FinishedBoard Nothing b) = 38 | show b ++ "\nDraw" 39 | show (FinishedBoard (Just p) b) = 40 | show b ++ "\n" ++ show p ++ " wins" 41 | 42 | data Position = 43 | N | E | S | W | NE | NW | SE | SW | C 44 | deriving (Ord, Eq, Show) 45 | 46 | data Outcome = 47 | InvalidMove 48 | | Inplay Board 49 | | Done FinishedBoard 50 | deriving Eq 51 | 52 | instance Show Outcome where 53 | show InvalidMove = 54 | "?" 55 | show (Inplay b) = 56 | show b 57 | show (Done b) = 58 | show b 59 | 60 | 61 | instance Show Board where 62 | show (Board m _) = 63 | let p x = case M.lookup x m of 64 | Nothing -> ' ' 65 | Just Naught -> 'O' 66 | Just Cross -> 'X' 67 | line a b c = 68 | concat 69 | [ 70 | "| " 71 | , [p a] 72 | , " | " 73 | , [p b] 74 | , " | " 75 | , [p c] 76 | , " |" 77 | ] 78 | blank = ".===.===.===." 79 | in intercalate "\n" 80 | [ 81 | blank 82 | , line NW N NE 83 | , blank 84 | , line W C E 85 | , blank 86 | , line SW S SE 87 | , blank 88 | ] 89 | 90 | start :: 91 | Position 92 | -> Board 93 | start p = 94 | Board (singleton p Naught) [(p, Naught)] 95 | 96 | move'' :: 97 | Outcome 98 | -> Position 99 | -> Outcome 100 | move'' InvalidMove _ = 101 | InvalidMove 102 | move'' (Inplay b) p = 103 | move b p 104 | move'' (Done b) _ = 105 | Done b 106 | 107 | data TakenBack = 108 | BoardBack Board 109 | | EmptyBack 110 | deriving (Eq, Show) 111 | 112 | takeBack' :: 113 | FinishedBoard 114 | -> Board 115 | takeBack' = 116 | undefined 117 | 118 | takeBack :: 119 | Board 120 | -> TakenBack 121 | takeBack = 122 | undefined 123 | 124 | move :: 125 | Board 126 | -> Position 127 | -> Outcome 128 | move board@(Board m h) p = 129 | if p `M.member` m 130 | then 131 | InvalidMove 132 | else 133 | let m' = M.insert p player m 134 | wins = 135 | [ 136 | (NW, N, NE) 137 | , (N, C, S) 138 | , (NE, E, SE) 139 | , (NW, N, NE) 140 | , (W, C, E) 141 | , (SW, S, SE) 142 | , (NW, C, SE) 143 | , (SW, C, NE) 144 | ] 145 | allEqual (a:b:t) = a == b && allEqual (b:t) 146 | allEqual _ = True 147 | isDraw = M.size m' >= 9 148 | isWin = any (\(a, b, c) -> any allEqual $ mapM (`M.lookup` m') [a, b, c]) wins 149 | player = whoseTurn board 150 | b' = Board m' ((p, player):h) 151 | in 152 | if isWin 153 | then Done (FinishedBoard (Just player) b') 154 | else 155 | if isDraw 156 | then Done (FinishedBoard Nothing b') 157 | else Inplay b' 158 | 159 | switch :: Player -> Player 160 | switch Cross = Naught 161 | switch Naught = Cross 162 | 163 | whoseTurn :: Board -> Player 164 | whoseTurn (Board _ ((_, p):_)) = 165 | switch p 166 | whoseTurn (Board _ []) = 167 | error "broke it" 168 | 169 | -- cabal install QuickCheck 170 | instance Arbitrary Position where 171 | arbitrary = elements [N, NE, NW, S, SE, SW, E, W, C] 172 | 173 | instance Arbitrary Player where 174 | arbitrary = elements [Naught, Cross] 175 | 176 | instance Arbitrary Board where 177 | arbitrary = do 178 | p <- arbitrary 179 | ps <- arbitrary 180 | return $ L.foldr propell (start p) ps 181 | 182 | propell :: Position -> Board -> Board 183 | propell p b = 184 | case move b p of 185 | InvalidMove -> b 186 | Done _ -> b 187 | Inplay b' -> b' 188 | 189 | data Blah = Blah Player Position Int 190 | 191 | instance Arbitrary Blah where 192 | arbitrary = do 193 | player <- arbitrary 194 | position <- arbitrary 195 | n <- choose (1, 9) 196 | return $ Blah player position n 197 | 198 | prop_eqp :: Position -> Bool 199 | prop_eqp n = n == n 200 | 201 | prop_eq :: Int -> Bool 202 | prop_eq n = n == n 203 | 204 | prop_switch :: Player -> Bool 205 | prop_switch p = switch p /= p 206 | 207 | main :: IO () 208 | main = do 209 | quickCheck prop_eqp 210 | quickCheck prop_eq 211 | quickCheck prop_switch 212 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe/Game.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe.Game where 2 | 3 | import Data.TicTacToe 4 | import Network.Server.Common.Env 5 | import Network.Server.Common.HandleLens 6 | import Network.Server.Common.Lens 7 | import Network.Server.Common.Line 8 | import Network.Server.Common.Ref 9 | import Network.Server.TicTacToe.Loop 10 | import Data.Char(isSpace, toLower, toUpper) 11 | import Data.Function(on) 12 | import Data.IORef(readIORef, atomicModifyIORef) 13 | import Data.Maybe(fromMaybe) 14 | import Data.Foldable(msum, find) 15 | import Data.Set(Set) 16 | import Control.Applicative((<$), (<$>)) 17 | import System.IO(hGetLine, hPutStrLn) 18 | 19 | type FinishedGames = 20 | [FinishedBoard] 21 | 22 | type Game a = 23 | IORefLoop Board (Board, FinishedGames) a 24 | 25 | data Command = 26 | Move Position 27 | | Current 28 | | Finished 29 | | Chat String 30 | | Turn 31 | | At Position 32 | | Unknown String 33 | deriving (Eq, Show) 34 | 35 | -- | 36 | -- 37 | -- >>> command "MOVE ne" 38 | -- Move NE 39 | -- 40 | -- >>> command "MOVE 2" 41 | -- Move N 42 | -- 43 | -- >>> command "GAME" 44 | -- Current 45 | -- 46 | -- >>> command "FiniSHED" 47 | -- Finished 48 | -- 49 | -- >>> command "CHAT hi" 50 | -- Chat "hi" 51 | -- 52 | -- >>> command "Turn" 53 | -- Turn 54 | -- 55 | -- >>> command "At 4" 56 | -- At W 57 | -- 58 | -- >>> command "At C" 59 | -- At C 60 | -- 61 | -- >>> command "At X" 62 | -- Unknown "At X" 63 | -- 64 | -- >>> command "Move i" 65 | -- Unknown "Move i" 66 | command :: 67 | String 68 | -> Command 69 | command z = 70 | let p l = reverse . dropWhile isSpace . reverse . dropWhile isSpace <$> prefixThen ((==) `on` toLower) l z 71 | in Unknown z `fromMaybe` msum [ 72 | do m <- p "MOVE " 73 | q <- sPosition m 74 | return (Move q) 75 | , Current <$ p "GAME" 76 | , Finished <$ p "FINISHED" 77 | , Chat <$> p "CHAT" 78 | , Turn <$ p "TURN" 79 | , do a <- p "AT" 80 | q <- sPosition a 81 | return (At q) 82 | ] 83 | 84 | -- | 85 | -- 86 | -- >>> sPosition "1" 87 | -- Just NW 88 | -- 89 | -- > sPosition "E" 90 | -- Just E 91 | -- 92 | -- > sPosition "sw" 93 | -- Just SW 94 | -- 95 | -- > sPosition "x" 96 | -- Nothing 97 | sPosition :: 98 | String 99 | -> Maybe Position 100 | sPosition s = 101 | let table = [ 102 | ( 103 | ["1", "NW"] 104 | , NW 105 | ) 106 | , ( 107 | ["2", "N"] 108 | , N 109 | ) 110 | , ( 111 | ["3", "NE"] 112 | , NE 113 | ) 114 | , ( 115 | ["4", "W"] 116 | , W 117 | ) 118 | , ( 119 | ["5", "C"] 120 | , C 121 | ) 122 | , ( 123 | ["6", "E"] 124 | , E 125 | ) 126 | , ( 127 | ["7", "SW"] 128 | , SW 129 | ) 130 | , ( 131 | ["8", "S"] 132 | , S 133 | ) 134 | , ( 135 | ["9", "SE"] 136 | , SE 137 | ) 138 | ] 139 | toUppers = map toUpper 140 | in fmap snd . find (\(t, _) -> elem (toUppers s) (toUppers <$> t)) $ table 141 | 142 | currentBoard :: 143 | Game Board 144 | currentBoard = 145 | initLoop $ \env -> 146 | readIORef (envvalL `getL` env) 147 | 148 | withCurrentBoard :: 149 | (Board -> (Board, a)) 150 | -> Game a 151 | withCurrentBoard f = 152 | initLoop $ \env -> 153 | atomicModifyIORef (envvalL `getL` env) f 154 | 155 | lastBoard :: 156 | Game Board 157 | lastBoard = 158 | Loop $ \_ (s, t) -> 159 | return (s, (s, t)) 160 | 161 | putBoard :: 162 | Board 163 | -> Game () 164 | putBoard s = 165 | Loop $ \_ (_, t) -> 166 | return ((), (s, t)) 167 | 168 | modifyFinishedGames :: 169 | (FinishedGames -> FinishedGames) 170 | -> Game () 171 | modifyFinishedGames f = 172 | Loop $ \_ (s, t) -> return ((), (s, f t)) 173 | 174 | finishedGames :: 175 | Game FinishedGames 176 | finishedGames = 177 | Loop $ \_ (s, t) -> return (t, (s, t)) 178 | 179 | eGetLine :: 180 | Game String 181 | eGetLine = 182 | initLoop (hGetLine . getL handleL) 183 | 184 | ePutStrLn :: 185 | String 186 | -> Game () 187 | ePutStrLn s = 188 | initLoop (\env -> (hPutStrLn (handleL `getL` env) s)) 189 | 190 | allClients :: 191 | Game (Set Ref) 192 | allClients = 193 | initLoop $ \env -> (readIORef (clientsL `getL` env)) 194 | 195 | process :: 196 | Command 197 | -> Game () 198 | process = 199 | error "todo" 200 | 201 | game :: 202 | Game x -- client accepted (post) 203 | -> (String -> Game w) -- read line from client 204 | -> IO a 205 | game = 206 | error "todo" 207 | 208 | play :: 209 | IO a 210 | play = 211 | game (currentBoard >>= pPutStrLn . show) (process . command) 212 | -------------------------------------------------------------------------------- /src/Course/Alternative.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE InstanceSigs #-} 4 | {-# LANGUAGE RebindableSyntax #-} 5 | 6 | module Course.Alternative where 7 | 8 | import Course.Applicative 9 | import Course.Core 10 | import Course.Functor 11 | import Course.List 12 | import Course.Optional 13 | import Course.Parser 14 | import qualified Prelude as P(fmap, return, (>>=)) 15 | 16 | -- | All instances of the `Alternative` type-class must satisfy three laws. 17 | -- These laws are not checked by the compiler. These laws are given as: 18 | -- 19 | -- * The law of left identity 20 | -- `∀x. empty <|> x = x` 21 | -- 22 | -- * The law of right identity 23 | -- `∀x. x <|> empty = x` 24 | -- 25 | -- * The law of associativity 26 | -- `∀u v w. u <|> (v <|> w) = (u <|> v) <|> w` 27 | -- 28 | -- You may notice that these are the same laws as Monoid. An alternative 29 | -- can be considered a "monoid on applicative functors". The key difference 30 | -- between the two classes is that Alternative is higher-kinded, meaning that 31 | -- the type variable @k@ itself takes a type parameter. 32 | -- The Alternative instance for @k@ is often distinct from any Monoid instance 33 | -- for @k a@. 34 | -- An Alternative instance should relate to the Applicative instance in some 35 | -- way, although the exact relation required is an open question in the community. 36 | -- Informally, it should be some kind of choice or alternation. Attempts to give 37 | -- laws relating the Applicative and Alternative are discussed here: 38 | -- https://wiki.haskell.org/Typeclassopedia#Laws_6 39 | class Applicative k => Alternative k where 40 | zero :: 41 | k a 42 | (<|>) :: 43 | k a 44 | -> k a 45 | -> k a 46 | 47 | infixl 3 <|> 48 | 49 | -- | Return the first full Optional. 50 | -- 51 | -- >>> Full 3 <|> zero 52 | -- Full 3 53 | -- 54 | -- >>> zero <|> Full 4 55 | -- Full 4 56 | -- 57 | -- >>> Full 3 <|> Full 4 58 | -- Full 3 59 | instance Alternative Optional where 60 | zero :: 61 | Optional a 62 | zero = 63 | Empty 64 | 65 | (<|>) :: 66 | Optional a 67 | -> Optional a 68 | -> Optional a 69 | (<|>) (Full a) _ = Full a 70 | (<|>) _ (Full a) = Full a 71 | (<|>) Empty Empty = Empty 72 | 73 | 74 | -- | Append the lists. 75 | -- This instance views lists as a non-deterministic choice between elements, 76 | -- so the way we "alternate" them is to append the lists. 77 | -- 78 | -- >>> 3 :. 4 :. 5 :. Nil <|> Nil 79 | -- [3,4,5] 80 | -- 81 | -- >>> Nil <|> 6 :. 7 :. 8 :. Nil 82 | -- [6,7,8] 83 | -- 84 | -- >>> 3 :. 4 :. 5 :. Nil <|> 6 :. 7 :. 8 :. Nil 85 | -- [3,4,5,6,7,8] 86 | instance Alternative List where 87 | zero :: 88 | List a 89 | zero = 90 | Nil 91 | (<|>) :: 92 | List a 93 | -> List a 94 | -> List a 95 | (<|>) xs ys = foldRight (\x ys' -> x :. ys') ys xs 96 | 97 | -- | Choose the first succeeding parser 98 | -- 99 | -- /Tip:/ Check Parser.hs 100 | -- 101 | -- >>> parse (character <|> valueParser 'v') "" 102 | -- Result >< 'v' 103 | -- 104 | -- >>> parse (constantParser UnexpectedEof <|> valueParser 'v') "" 105 | -- Result >< 'v' 106 | -- 107 | -- >>> parse (character <|> valueParser 'v') "abc" 108 | -- Result >bc< 'a' 109 | -- 110 | -- >>> parse (constantParser UnexpectedEof <|> valueParser 'v') "abc" 111 | -- Result >abc< 'v' 112 | instance Alternative Parser where 113 | zero :: 114 | Parser a 115 | zero = 116 | P (\_ -> UnexpectedEof) 117 | (<|>) :: 118 | Parser a 119 | -> Parser a 120 | -> Parser a 121 | (<|>) (P p1) (P p2)= 122 | P $ \input -> 123 | let r1 = p1 input 124 | r2 = p2 input 125 | in if isErrorResult r1 126 | then r2 127 | else r1 128 | 129 | -- | Run the provided Alternative action zero or more times, collecting 130 | -- a list of the results. 131 | -- 132 | -- /Tip:/ Use @some@, @pure@ and @(<|>)@. 133 | -- 134 | -- >>> parse (many character) "" 135 | -- Result >< "" 136 | -- 137 | -- >>> parse (many digit) "123abc" 138 | -- Result >abc< "123" 139 | -- 140 | -- >>> parse (many digit) "abc" 141 | -- Result >abc< "" 142 | -- 143 | -- >>> parse (many character) "abc" 144 | -- Result >< "abc" 145 | -- 146 | -- >>> parse (many (character *> valueParser 'v')) "abc" 147 | -- Result >< "vvv" 148 | -- 149 | -- >>> parse (many (character *> valueParser 'v')) "" 150 | -- Result >< "" 151 | many :: Alternative k => k a -> k (List a) 152 | many ka = 153 | let kas = some ka 154 | in kas <|> pure Nil 155 | 156 | -- | Run the provided Alternative action one or more times, collecting 157 | -- a list of the results. 158 | -- 159 | -- /Tip:/ Use @(:.)@ and @many@. 160 | -- 161 | -- >>> parse (some (character)) "abc" 162 | -- Result >< "abc" 163 | -- 164 | -- >>> parse (some (character *> valueParser 'v')) "abc" 165 | -- Result >< "vvv" 166 | -- 167 | -- >>> isErrorResult (parse (some (character *> valueParser 'v')) "") 168 | -- True 169 | some :: Alternative k => k a -> k (List a) 170 | some ka = 171 | lift2 (:.) ka (many ka) 172 | 173 | -- | Combine a list of alternatives 174 | -- 175 | -- >>> aconcat (Nil :: List (List Int)) 176 | -- [] 177 | -- 178 | -- >>> aconcat ((3:.4:.Nil) :. Nil :. (5:.6:.Nil) :. Nil) 179 | -- [3,4,5,6] 180 | 181 | -- >>> aconcat (Empty :. Empty :. Full 7 :. Empty :. Full 8 :. Empty :. Nil) 182 | -- Full 7 183 | -- 184 | -- /Note:/ In the standard library, this function is called @asum@ 185 | aconcat :: Alternative k => List (k a) -> k a 186 | aconcat = 187 | foldRight (<|>) zero 188 | -------------------------------------------------------------------------------- /projects/NetworkServer/haskell/src/Network/Server/TicTacToe/Loop.hs: -------------------------------------------------------------------------------- 1 | module Network.Server.TicTacToe.Loop where 2 | 3 | import Prelude hiding (mapM_, catch) 4 | import System.IO(BufferMode(..)) 5 | import Network(PortID(..), sClose, withSocketsDo, listenOn) 6 | import Data.IORef(IORef, newIORef, readIORef) 7 | import Data.Foldable(Foldable, mapM_) 8 | import Control.Applicative(Applicative, pure) 9 | import Control.Monad.Trans(MonadIO(..), MonadTrans(..)) 10 | import Control.Monad(liftM) 11 | import Control.Concurrent(forkIO) 12 | import Control.Exception(finally, try, catch, Exception) 13 | import Control.Monad(forever) 14 | 15 | import Network.Server.Common.Accept 16 | import Network.Server.Common.HandleLens 17 | import Network.Server.Common.Lens 18 | import Network.Server.Common.Line 19 | import Network.Server.Common.Env 20 | import Network.Server.Common.Ref 21 | import Data.Set(Set) 22 | import qualified Data.Set as S 23 | 24 | data Loop v s f a = 25 | Loop (Env v -> s -> f (a, s)) 26 | 27 | type IOLoop v s a = 28 | Loop v s IO a 29 | 30 | type IORefLoop v s a = 31 | IOLoop (IORef v) s a 32 | 33 | execLoop :: 34 | Functor f => 35 | Loop v s f a 36 | -> Env v 37 | -> s 38 | -> f a 39 | execLoop (Loop l) e = 40 | fmap fst . l e 41 | 42 | initLoop :: 43 | Functor f => 44 | (Env v -> f a) 45 | -> Loop v s f a 46 | initLoop f = 47 | Loop $ \env s -> fmap (\a -> (a, s)) . f $ env 48 | 49 | instance Functor f => Functor (Loop v s f) where 50 | fmap f (Loop k) = 51 | Loop (\env -> fmap (\(a, t) -> (f a, t)) . k env) 52 | 53 | instance Applicative f => Applicative (Loop v s f) where 54 | pure = undefined 55 | (<*>) = undefined 56 | 57 | instance Monad f => Monad (Loop v s f) where 58 | return a = 59 | Loop $ \_ s -> return (a, s) 60 | Loop k >>= f = 61 | Loop (\env s -> k env s >>= \(a, t) -> 62 | let Loop l = f a 63 | in l env t) 64 | 65 | instance MonadTrans (Loop v s) where 66 | lift x = 67 | Loop (\_ s -> liftM (\a -> (a, s)) x) 68 | 69 | instance MonadIO f => MonadIO (Loop v s f) where 70 | liftIO = 71 | lift . liftIO 72 | 73 | etry :: 74 | Exception e => 75 | (Env v -> IO a) 76 | -> IOLoop v s (Either e a) 77 | etry k = 78 | initLoop $ try . k 79 | 80 | server :: 81 | IO w -- server initialise 82 | -> (w -> IO v) -- client accepted (pre) 83 | -> s -- initial state 84 | -> IOLoop v s () -- per-client 85 | -> IO a 86 | server i r t l = 87 | let hand s w c = forever $ 88 | do q <- accept' s 89 | lSetBuffering q NoBuffering 90 | _ <- atomicModifyIORef_ c (S.insert (refL `getL` q)) 91 | x <- r w 92 | forkIO (execLoop l (Env q c x) t) 93 | in withSocketsDo $ do 94 | s <- listenOn (PortNumber 6060) 95 | w <- i 96 | c <- newIORef S.empty 97 | hand s w c `finally` sClose s 98 | 99 | perClient :: 100 | IOLoop v s x -- client accepted (post) 101 | -> (String -> IOLoop v s a) -- read line from client 102 | -> IOLoop v s () 103 | perClient q f = 104 | let lp = do k <- etry lGetLine 105 | case k of Left e -> xprint e 106 | Right [] -> lp 107 | Right l -> f l >> lp 108 | in do _ <- q 109 | lp 110 | 111 | loop :: 112 | IO w -- server initialise 113 | -> (w -> IO v) -- client accepted (pre) 114 | -> s -- initial state 115 | -> IOLoop v s x -- client accepted (post) 116 | -> (String -> IOLoop v s w) -- read line from client 117 | -> IO a 118 | loop i r s q f = 119 | server i r s (perClient q f) 120 | 121 | iorefServer :: 122 | v -- server initialise 123 | -> s -- initial state 124 | -> IORefLoop v s () -- per-client 125 | -> IO a 126 | iorefServer x s = 127 | server (newIORef x) return s 128 | 129 | iorefLoop :: 130 | v -- server initialise 131 | -> s -- initial state 132 | -> IORefLoop v s x -- client accepted (post) 133 | -> (String -> IORefLoop v s w) -- read line from client 134 | -> IO a 135 | iorefLoop x s q f = 136 | iorefServer x s (perClient q f) 137 | 138 | pPutStrLn :: 139 | String 140 | -> IOLoop v s () 141 | pPutStrLn s = 142 | initLoop (`lPutStrLn` s) 143 | 144 | (!) :: 145 | Foldable t => 146 | IOLoop v s (t Ref) 147 | -> String 148 | -> IOLoop v s () 149 | clients ! msg = 150 | clients >>= purgeClients (\y -> liftIO (lPutStrLn y msg)) 151 | 152 | infixl 2 ! 153 | 154 | purgeClients :: 155 | Foldable t => 156 | (Ref -> IOLoop s v ()) 157 | -> t Ref 158 | -> IOLoop s v () 159 | purgeClients a = 160 | mapM_ (\y -> 161 | ecatch (a y) 162 | (\x -> do _ <- modifyClients (S.delete y) 163 | xprint x) 164 | ) 165 | 166 | readEnv :: 167 | Applicative f => 168 | Loop v s f (Env v) 169 | readEnv = 170 | initLoop $ pure 171 | 172 | readEnvval :: 173 | Applicative f => 174 | Loop v s f v 175 | readEnvval = 176 | fmap (envvalL `getL`) readEnv 177 | 178 | readIOEnvval :: 179 | IORefLoop a s a 180 | readIOEnvval = 181 | initLoop $ \env -> 182 | readIORef (envvalL `getL` env) 183 | 184 | allClientsButThis :: 185 | IOLoop v s (Set Ref) 186 | allClientsButThis = 187 | initLoop $ \env -> 188 | fmap (S.delete ((acceptL .@ refL) `getL` env)) (readIORef (clientsL `getL` env)) 189 | 190 | -- Control.Monad.CatchIO 191 | ecatch :: 192 | Exception e => 193 | IOLoop v s a 194 | -> (e -> IOLoop v s a) 195 | -> IOLoop v s a 196 | ecatch (Loop k) f = 197 | Loop $ \env s -> k env s `catch` (\e -> let Loop l = f e in l env s) 198 | 199 | modifyClients :: 200 | (Set Ref -> Set Ref) 201 | -> IOLoop v s (Set Ref) 202 | modifyClients f = 203 | initLoop $ \env -> 204 | atomicModifyIORef_ (clientsL `getL` env) f 205 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/Board.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.*; 4 | import fj.data.List; 5 | import fj.data.Option; 6 | import fj.data.TreeMap; 7 | 8 | import static fj.P.p; 9 | import static fj.data.List.list; 10 | import static fj.data.List.nil; 11 | import static fj.data.Option.none; 12 | import static tictactoe.GameResult.Draw; 13 | import static tictactoe.GameResult.win; 14 | import static tictactoe.Player.Player1; 15 | import static tictactoe.Player.toSymbol; 16 | import static tictactoe.Position.*; 17 | 18 | public final class Board extends BoardLike { 19 | private final List> moves; 20 | private final TreeMap m; 21 | 22 | private static final Ord positionOrder = Ord.comparableOrd(); 23 | 24 | private Board(final List> moves, final TreeMap m) { 25 | this.moves = moves; 26 | this.m = m; 27 | } 28 | 29 | public Player whoseTurn() { 30 | return moves.head()._2().alternate(); 31 | } 32 | 33 | public boolean isEmpty() { 34 | return false; 35 | } 36 | 37 | public List occupiedPositions() { 38 | return m.keys(); 39 | } 40 | 41 | public int nmoves() { 42 | return m.size(); 43 | } 44 | 45 | public Option playerAt(Position p) { 46 | return m.get(p); 47 | } 48 | 49 | public TakenBack takeBack() { 50 | return moves.isEmpty() ? 51 | TakenBack.isEmpty() : 52 | TakenBack.isBoard(new Board(moves.tail(), m.delete(moves.head()._1()))); 53 | } 54 | 55 | @SuppressWarnings("unchecked") 56 | public MoveResult moveTo(final Position p) { 57 | final Player wt = whoseTurn(); 58 | final Option j = m.get(p); 59 | final TreeMap mm = m.set(p, wt); 60 | final Board bb = new Board(moves.cons(P.p(p, wt)), mm); 61 | final List> wins = 62 | list( 63 | P.p(NW, W, SW) 64 | , P.p(N, C, S) 65 | , P.p(NE, E, SE) 66 | , P.p(NW, N, NE) 67 | , P.p(W, C, E) 68 | , P.p(SW, S, SE) 69 | , P.p(NW, C, SE) 70 | , P.p(SW, C, NE) 71 | ); 72 | final boolean isWin = wins.exists(new F, Boolean>() { 73 | public Boolean f(final P3 abc) { 74 | return list(abc._1(), abc._2(), abc._3()).mapMOption(mm.get()).exists(new F, Boolean>() { 75 | public Boolean f(final List ps) { 76 | return ps.allEqual(Equal.anyEqual()); 77 | } 78 | }); 79 | } 80 | }); 81 | 82 | final boolean isDraw = Position.positions().forall(new F() { 83 | public Boolean f(final Position p) { 84 | return m.contains(p); 85 | } 86 | }); 87 | 88 | return j.isSome() ? 89 | MoveResult.positionAlreadyOccupied() : 90 | isWin ? 91 | MoveResult.gameOver(new FinishedBoard(bb, GameResult.win(wt))) : 92 | isDraw ? 93 | MoveResult.gameOver(new FinishedBoard(bb, Draw)) : 94 | MoveResult.keepPlaying(bb); 95 | } 96 | 97 | @Override 98 | public String toString() { 99 | return toString(new F2, Position, Character>() { 100 | public Character f(final Option p, final Position _) { 101 | return p.option(P.p(' '), toSymbol); 102 | } 103 | }) + "\n[ " + whoseTurn().toString() + " to move ]"; 104 | } 105 | 106 | public static final class EmptyBoard extends BoardLike { 107 | private EmptyBoard() {} 108 | 109 | @SuppressWarnings("unchecked") 110 | public Board moveTo(final Position p) { 111 | return new Board(list(p(p, Player1)), TreeMap.empty(positionOrder).set(p, Player1)); 112 | } 113 | 114 | private static final EmptyBoard e = new EmptyBoard(); 115 | public static EmptyBoard empty() { 116 | return e; 117 | } 118 | 119 | public Player whoseTurn() { 120 | return Player1; 121 | } 122 | 123 | public boolean isEmpty() { 124 | return true; 125 | } 126 | 127 | public List occupiedPositions() { 128 | return nil(); 129 | } 130 | 131 | public int nmoves() { 132 | return 0; 133 | } 134 | 135 | public Option playerAt(Position p) { 136 | return none(); 137 | } 138 | } 139 | 140 | public static final class FinishedBoard extends BoardLike { 141 | private final Board b; 142 | private final GameResult r; 143 | 144 | private FinishedBoard(final Board b, final GameResult r) { 145 | this.b = b; 146 | this.r = r; 147 | } 148 | 149 | public Board takeBack() { 150 | return b.takeBack().fold( 151 | Bottom.error_("Broken invariant: board in-play with empty move list. This is a program bug") 152 | , Function.identity() 153 | ); 154 | } 155 | 156 | public Player whoseTurn() { 157 | return b.whoseTurn(); 158 | } 159 | 160 | public boolean isEmpty() { 161 | return false; 162 | } 163 | 164 | public List occupiedPositions() { 165 | return b.occupiedPositions(); 166 | } 167 | 168 | public int nmoves() { 169 | return b.nmoves(); 170 | } 171 | 172 | public Option playerAt(final Position p) { 173 | return b.playerAt(p); 174 | } 175 | 176 | public GameResult result() { 177 | return r; 178 | } 179 | 180 | @Override 181 | public String toString() { 182 | return b.toString() + "\n[[" + r.toString() + " ]]"; 183 | } 184 | } 185 | } 186 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # haskell-ci 'course.cabal' '--output' '.travis.yml' 4 | # 5 | # For more information, see https://github.com/haskell-CI/haskell-ci 6 | # 7 | language: c 8 | dist: xenial 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.6.3" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.6.3], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.4.4" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.4.4], sources: [hvr-ghc]}} 37 | - compiler: "ghc-8.2.2" 38 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 39 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.2.2], sources: [hvr-ghc]}} 40 | - compiler: "ghc-8.0.2" 41 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 42 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-8.0.2], sources: [hvr-ghc]}} 43 | - compiler: "ghc-7.10.3" 44 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 45 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-2.4,ghc-7.10.3], sources: [hvr-ghc]}} 46 | 47 | before_install: 48 | - HC=${CC} 49 | - HCPKG=${HC/ghc/ghc-pkg} 50 | - unset CC 51 | - ROOTDIR=$(pwd) 52 | - mkdir -p $HOME/.local/bin 53 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 54 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 55 | - echo $HCNUMVER 56 | 57 | install: 58 | - cabal --version 59 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 60 | - BENCH=${BENCH---enable-benchmarks} 61 | - TEST=${TEST---enable-tests} 62 | - UNCONSTRAINED=${UNCONSTRAINED-true} 63 | - GHCHEAD=${GHCHEAD-false} 64 | - travis_retry cabal update -v 65 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 66 | - rm -fv cabal.project cabal.project.local 67 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 68 | - rm -f cabal.project 69 | - touch cabal.project 70 | - "printf 'packages: \".\"\\n' >> cabal.project" 71 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 72 | - touch cabal.project.local 73 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(course)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 74 | - cat cabal.project || true 75 | - cat cabal.project.local || true 76 | - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi 77 | - rm -f cabal.project.freeze 78 | - cabal new-freeze -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dry 79 | - "cat \"cabal.project.freeze\" | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" 80 | - rm "cabal.project.freeze" 81 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 82 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 83 | - rm -rf .ghc.environment.* "."/dist 84 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 85 | 86 | # Here starts the actual work to be performed for the package under test; 87 | # any command which exits with a non-zero exit code causes the build to fail. 88 | script: 89 | # test that source-distributions can be generated 90 | - cabal new-sdist all 91 | - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ 92 | - cd ${DISTDIR} || false 93 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 94 | - rm -f cabal.project 95 | - touch cabal.project 96 | - "printf 'packages: \"course-*/*.cabal\"\\n' >> cabal.project" 97 | - "printf 'write-ghc-environment-files: always\\n' >> cabal.project" 98 | - touch cabal.project.local 99 | - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | grep -vE -- '^(course)$' | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" 100 | - cat cabal.project || true 101 | - cat cabal.project.local || true 102 | # this builds all libraries and executables (without tests/benchmarks) 103 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 104 | 105 | # build & run tests, build benchmarks 106 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 107 | # MODIFIED - build the tests but don't run them 108 | #- if [ "x$TEST" = "x--enable-tests" ]; then cabal new-test -w ${HC} ${TEST} ${BENCH} all; fi 109 | 110 | # cabal check 111 | - (cd course-* && cabal check) 112 | 113 | # haddock 114 | - cabal new-haddock -w ${HC} ${TEST} ${BENCH} all 115 | 116 | # Build without installed constraints for packages in global-db 117 | - if $UNCONSTRAINED; then rm -f cabal.project.local; cabal new-build -w ${HC} --disable-tests --disable-benchmarks all; else echo "Not building without installed constraints"; fi 118 | 119 | # REGENDATA ["course.cabal","--output",".travis.yml"] 120 | # EOF 121 | -------------------------------------------------------------------------------- /test/Course/JsonParserTest.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-type-defaults #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.JsonParserTest where 6 | 7 | import Data.Ratio ((%)) 8 | import Test.Tasty (TestTree, testGroup) 9 | import Test.Tasty.HUnit (testCase, (@?=)) 10 | 11 | import Course.Core 12 | import Course.JsonParser (jsonArray, jsonFalse, jsonNull, jsonNumber, 13 | jsonObject, jsonString, jsonTrue, jsonValue) 14 | import Course.JsonValue (JsonValue (..)) 15 | import Course.List (List (..)) 16 | import Course.Parser (ParseResult (..), isErrorResult, parse) 17 | 18 | test_JsonParser :: TestTree 19 | test_JsonParser = 20 | testGroup "JsonParser" [ 21 | jsonStringTest 22 | , jsonNumberTest 23 | , jsonTrueTest 24 | , jsonFalseTest 25 | , jsonNullTest 26 | , jsonArrayTest 27 | , jsonObjectTest 28 | ] 29 | 30 | jsonStringTest :: TestTree 31 | jsonStringTest = 32 | testGroup "jsonString" [ 33 | testCase "parse whole ASCII input" $ 34 | parse jsonString "\" abc\"" @?= Result "" " abc" 35 | , testCase "parse only the first string of input" $ 36 | parse jsonString "\"abc\"def" @?= Result "def" "abc" 37 | , testCase "parse back slash (\\)" $ 38 | parse jsonString "\"\\babc\"def" @?= Result "def" "\babc" 39 | , testCase "parse unicode (\\u00abc)" $ 40 | parse jsonString "\"\\u00abc\"def" @?= Result "def" "«c" 41 | , testCase "parse unicode (\\u00ff)" $ 42 | parse jsonString "\"\\u00ffabc\"def" @?= Result "def" "ÿabc" 43 | , testCase "parse unicode (\\u00fa)" $ 44 | parse jsonString "\"\\u00faabc\"def" @?= Result "def" "úabc" 45 | , testCase "parsing string without quotes is an error" $ 46 | isErrorResult (parse jsonString "abc") @?= True 47 | , testCase "parsing string containing \\a is an error - \\a isn't a special character" $ 48 | isErrorResult (parse jsonString "\"\\abc\"def") @?= True 49 | ] 50 | 51 | jsonNumberTest :: TestTree 52 | jsonNumberTest = 53 | testGroup "jsonNumber" [ 54 | testCase "positive whole" $ parse jsonNumber "234" @?= Result "" (234 % 1) 55 | , testCase "negative whole" $ parse jsonNumber "-234" @?= Result "" ((-234) % 1) 56 | , testCase "positive decimal" $ parse jsonNumber "123.45" @?= Result "" (2469 % 20) 57 | , testCase "negative whole (2)" $ parse jsonNumber "-123" @?= Result "" ((-123) % 1) 58 | , testCase "negative decimal" $ parse jsonNumber "-123.45" @?= Result "" ((-2469) % 20) 59 | , testCase "negative sign on its own is error" $ isErrorResult (parse jsonNumber "-") @?= True 60 | , testCase "alphabetic characters is error" $ isErrorResult (parse jsonNumber "abc") @?= True 61 | ] 62 | 63 | jsonTrueTest :: TestTree 64 | jsonTrueTest = 65 | testGroup "jsonTrue" [ 66 | testCase "parses true" $ parse jsonTrue "true" @?= Result "" "true" 67 | , testCase "TRUE (caps) is an error" $ isErrorResult (parse jsonTrue "TRUE") @?= True 68 | ] 69 | 70 | jsonFalseTest :: TestTree 71 | jsonFalseTest = 72 | testGroup "jsonFalse" [ 73 | testCase "parses false" $ parse jsonFalse "false" @?= Result "" "false" 74 | , testCase "FALSE (caps) is an error" $ isErrorResult (parse jsonFalse "FALSE") @?= True 75 | ] 76 | 77 | jsonNullTest :: TestTree 78 | jsonNullTest = 79 | testGroup "jsonNull" [ 80 | testCase "parses null" $ parse jsonNull "null" @?= Result "" "null" 81 | , testCase "NULL (caps) is an error" $ isErrorResult (parse jsonNull "NULL") @?= True 82 | ] 83 | 84 | jsonArrayTest :: TestTree 85 | jsonArrayTest = 86 | testGroup "jsonArray" [ 87 | testCase "[]" $ 88 | parse jsonArray "[]" @?= Result "" Nil 89 | , testCase "[true]" $ 90 | parse jsonArray "[true]" @?= Result "" (JsonTrue :. Nil) 91 | , testCase "[true, \"abc\"]" $ 92 | parse jsonArray "[true, \"abc\"]" @?= Result "" (JsonTrue :. JsonString "abc" :. Nil) 93 | , testCase "[true, \"abc\", []]" $ 94 | parse jsonArray "[true, \"abc\", []]" @?= Result "" (JsonTrue :. JsonString "abc" :. JsonArray Nil :. Nil) 95 | , testCase "[true, \"abc\", [false]]" $ 96 | let result = Result "" (JsonTrue :. JsonString "abc" :. JsonArray (JsonFalse :. Nil) :. Nil) 97 | in parse jsonArray "[true, \"abc\", [false]]" @?= result 98 | ] 99 | 100 | jsonObjectTest :: TestTree 101 | jsonObjectTest = 102 | testGroup "jsonObject" [ 103 | testCase "empty" $ 104 | parse jsonObject "{}" @?= Result "" Nil 105 | , testCase "one key" $ 106 | parse jsonObject "{ \"key1\" : true }" @?= Result "" (("key1",JsonTrue) :. Nil) 107 | , testCase "two keys" $ 108 | parse jsonObject "{ \"key1\" : true , \"key2\" : false }" @?= Result "" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) 109 | , testCase "two keys and left over input" $ 110 | let result = Result "xyz" (("key1",JsonTrue):.("key2",JsonFalse):.Nil) 111 | in parse jsonObject "{ \"key1\" : true , \"key2\" : false } xyz" @?= result 112 | ] 113 | 114 | jsonValueTest :: TestTree 115 | jsonValueTest = 116 | testGroup "jsonValue" [ 117 | testCase "true" $ 118 | parse jsonValue "true" @?= Result "" JsonTrue 119 | , testCase "object" $ 120 | let result = Result "" ( ("key1",JsonTrue) 121 | :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse:.Nil)) 122 | :. Nil 123 | ) 124 | in parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] }" @?= result 125 | , testCase "nested object" $ 126 | let result = Result "" ( ("key1",JsonTrue) 127 | :. ("key2",JsonArray (JsonRational (7 % 1) :. JsonFalse :. Nil)) 128 | :. ("key3",JsonObject (("key4",JsonNull) :. Nil)) 129 | :. Nil 130 | ) 131 | in parse jsonObject "{ \"key1\" : true , \"key2\" : [7, false] , \"key3\" : { \"key4\" : null } }" @?= result 132 | ] 133 | -------------------------------------------------------------------------------- /src/Course/Interactive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | 5 | module Course.Interactive where 6 | 7 | import Course.Core 8 | import Course.Functor 9 | import Course.Applicative 10 | import Course.Monad 11 | import Course.Traversable 12 | import Course.List 13 | import Course.Optional 14 | 15 | -- | Eliminates any value over which a functor is defined. 16 | vooid :: 17 | Functor m => 18 | m a 19 | -> m () 20 | vooid = 21 | (<$>) (const ()) 22 | 23 | -- | A version of @bind@ that ignores the result of the effect. 24 | (>-) :: 25 | Monad m => 26 | m a 27 | -> m b 28 | -> m b 29 | (>-) a = 30 | (>>=) a . const 31 | 32 | -- | Runs an action until a result of that action satisfies a given predicate. 33 | untilM :: 34 | Monad m => 35 | (a -> m Bool) -- ^ The predicate to satisfy to stop running the action. 36 | -> m a -- ^ The action to run until the predicate satisfies. 37 | -> m a 38 | untilM p a = 39 | a >>= \r -> 40 | p r >>= \q -> 41 | if q 42 | then 43 | pure r 44 | else 45 | untilM p a 46 | 47 | -- | Example program that uses IO to echo back characters that are entered by the user. 48 | echo :: 49 | IO () 50 | echo = 51 | vooid (untilM 52 | (\c -> 53 | if c == 'q' 54 | then 55 | putStrLn "Bye!" >- 56 | pure True 57 | else 58 | pure False) 59 | (putStr "Enter a character: " >- 60 | getChar >>= \c -> 61 | putStrLn "" >- 62 | putStrLn (c :. Nil) >- 63 | pure c)) 64 | 65 | data Op = 66 | Op Char Chars (IO ()) -- keyboard entry, description, program 67 | 68 | -- | 69 | -- 70 | -- * Ask the user to enter a string to convert to upper-case. 71 | -- 72 | -- * Convert the string to upper-case. 73 | -- 74 | -- * Print the upper-cased string to standard output. 75 | -- 76 | -- /Tip:/ @getLine :: IO String@ -- an IO action that reads a string from standard input. 77 | -- 78 | -- /Tip:/ @toUpper :: Char -> Char@ -- (Data.Char) converts a character to upper-case. 79 | -- 80 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 81 | -- 82 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 83 | convertInteractive :: 84 | IO () 85 | convertInteractive = 86 | putStr "Enter a String to upper-case: " >- 87 | getLine >>= \l -> 88 | putStrLn (toUpper <$> l) >- 89 | putStrLn "" 90 | 91 | -- | 92 | -- 93 | -- * Ask the user to enter a file name to reverse. 94 | -- 95 | -- * Ask the user to enter a file name to write the reversed file to. 96 | -- 97 | -- * Read the contents of the input file. 98 | -- 99 | -- * Reverse the contents of the input file. 100 | -- 101 | -- * Write the reversed contents to the output file. 102 | -- 103 | -- /Tip:/ @getLine :: IO String@ -- an IO action that reads a string from standard input. 104 | -- 105 | -- /Tip:/ @readFile :: FilePath -> IO String@ -- an IO action that reads contents of a file. 106 | -- 107 | -- /Tip:/ @writeFile :: FilePath -> String -> IO ()@ -- writes a string to a file. 108 | -- 109 | -- /Tip:/ @reverse :: [a] -> [a]@ -- reverses a list. 110 | -- 111 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 112 | -- 113 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 114 | reverseInteractive :: 115 | IO () 116 | reverseInteractive = 117 | putStr "Enter a file name to reverse: " >- 118 | getLine >>= \infile -> 119 | putStr "Enter a file name to output: " >- 120 | getLine >>= \outfile -> 121 | readFile infile >>= \i -> 122 | writeFile outfile (reverse i) >- 123 | putStrLn "" 124 | 125 | -- | 126 | -- 127 | -- * Ask the user to enter a string to url-encode. 128 | -- 129 | -- * Convert the string with a URL encoder. 130 | -- 131 | -- * For simplicity, encoding is defined as: 132 | -- 133 | -- * @' ' -> \"%20\"@ 134 | -- 135 | -- * @'\t' -> \"%09\"@ 136 | -- 137 | -- * @'\"' -> \"%22\"@ 138 | -- 139 | -- * @/anything else is unchanged/@ 140 | -- 141 | -- * Print the encoded URL to standard output. 142 | -- 143 | -- /Tip:/ @putStr :: String -> IO ()@ -- Prints a string to standard output. 144 | -- 145 | -- /Tip:/ @putStrLn :: String -> IO ()@ -- Prints a string and then a new line to standard output. 146 | encodeInteractive :: 147 | IO () 148 | encodeInteractive = 149 | let encode :: 150 | Chars 151 | -> Chars 152 | encode url = 153 | url >>= \c -> case c of 154 | ' ' -> "%20" 155 | '\t' -> "%09" 156 | '"' -> "%22" 157 | _ -> c :. Nil 158 | in putStr "Enter a URL to encode: " >- 159 | getLine >>= \l -> 160 | putStrLn (encode l) >- 161 | putStrLn "" 162 | 163 | interactive :: 164 | IO () 165 | interactive = 166 | let ops = ( 167 | Op 'c' "Convert a string to upper-case" convertInteractive 168 | :. Op 'r' "Reverse a file" reverseInteractive 169 | :. Op 'e' "Encode a URL" encodeInteractive 170 | :. Op 'q' "Quit" (pure ()) 171 | :. Nil 172 | ) 173 | in vooid (untilM 174 | (\c -> 175 | if c == 'q' 176 | then 177 | putStrLn "Bye!" >- 178 | pure True 179 | else 180 | pure False) 181 | (putStrLn "Select: " >- 182 | traverse (\(Op c s _) -> 183 | putStr (c :. Nil) >- 184 | putStr ". " >- 185 | putStrLn s) ops >- 186 | getChar >>= \c -> 187 | putStrLn "" >- 188 | let o = find (\(Op c' _ _) -> c' == c) ops 189 | r = case o of 190 | Empty -> (putStrLn "Not a valid selection. Try again." >-) 191 | Full (Op _ _ k) -> (k >-) 192 | in r (pure c))) 193 | -------------------------------------------------------------------------------- /projects/TicTacToe/haskell/src/TicTacToe/Console.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | 3 | module Main( 4 | main 5 | ) where 6 | 7 | import Control.Applicative(Const) 8 | import Control.Category((.)) 9 | import Control.Lens(( # ), (^?), (%~)) 10 | 11 | import Data.Foldable(mapM_) 12 | import Data.Function(const) 13 | import Data.Int(Int) 14 | import Data.List(intercalate, concat, elem, (++)) 15 | import Data.Maybe 16 | import Data.Monoid(Endo, First) 17 | import Data.String(String) 18 | import System.IO(hSetBuffering, stdin, BufferMode(NoBuffering), putStrLn, getChar, print, IO) 19 | import TicTacToe(Position(P1, P2, P3, P4, P5, P6, P7, P8, P9), AsWin(_Win), AsPlayer(_Player), Player, AsPosition(_Position), IndexingN, whoseTurn, WinOccupiedOr(IsOccupiedOr, Win), OccupiedOr(Occupied, Or), positionPlayer, start, move2, move3, move4, move5, move6, move7, move8, move9, Win5, Win6, Win7, Win8, Win9, Move1, Move2, Move3, Move4, Move5, Move6, Move7, Move8, Move9) 20 | import Prelude(show) 21 | 22 | main :: 23 | IO () 24 | main = 25 | do hSetBuffering stdin NoBuffering 26 | let moveto5 :: 27 | (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => 28 | (Position -> g -> OccupiedOr t) 29 | -> (t -> IO ()) 30 | -> g 31 | -> IO () 32 | moveto5 = 33 | pernextmove IsOccupiedOr 34 | 35 | movefrom5 :: 36 | (AsPosition (->) (Const (Endo (Endo Int))) h, AsPosition (->) (IndexingN Player (Const (First Player))) g, AsPosition (->) (IndexingN Player (Const (First Player))) h) => 37 | (Position -> h -> WinOccupiedOr g t) 38 | -> (t -> IO ()) 39 | -> h 40 | -> IO () 41 | movefrom5 = 42 | pernextmove (_Win %~ (\a t -> do putStrLn (showWithoutPositions a) 43 | putStrLn (showPlayer (whoseTurn t) ++ " wins"))) 44 | 45 | play (permove . const) moveto5 moveto5 moveto5 movefrom5 movefrom5 movefrom5 movefrom5 movefrom5 print 46 | 47 | play :: 48 | ((Position -> c) -> () -> t) 49 | -> ((Position -> Move1 -> OccupiedOr Move2) -> t1 -> Move1 -> c) 50 | -> ((Position -> Move2 -> OccupiedOr Move3) -> t2 -> t1) 51 | -> ((Position -> Move3 -> OccupiedOr Move4) -> t3 -> t2) 52 | -> ((Position -> Move4 -> WinOccupiedOr Win5 Move5) -> t4 -> t3) 53 | -> ((Position -> Move5 -> WinOccupiedOr Win6 Move6) -> t5 -> t4) 54 | -> ((Position -> Move6 -> WinOccupiedOr Win7 Move7) -> t6 -> t5) 55 | -> ((Position -> Move7 -> WinOccupiedOr Win8 Move8) -> t7 -> t6) 56 | -> ((Position -> Move8 -> WinOccupiedOr Win9 Move9) -> t8 -> t7) 57 | -> t8 58 | -> t 59 | play pm m1 m2 m3 m4 m5 m6 m7 m8 m9 = 60 | pm (m1 move2 (m2 move3 (m3 move4 (m4 move5 (m5 move6 (m6 move7 (m7 move8 (m8 move9 m9))))))) . start) () 61 | 62 | pernextmove :: 63 | (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => 64 | (b -> WinOccupiedOr (g -> IO ()) t) 65 | -> (Position -> g -> b) 66 | -> (t -> IO ()) 67 | -> g 68 | -> IO () 69 | pernextmove k fr j g = 70 | permove (\t p -> case k (fr p g) of 71 | Win w -> w t 72 | IsOccupiedOr Occupied -> do putStrLn "That position is already occupied. Please try again." 73 | pernextmove k fr j g 74 | IsOccupiedOr (Or m) -> j m) g 75 | 76 | permove :: 77 | (AsPosition (->) (Const (Endo (Endo Int))) g, AsPosition (->) (IndexingN Player (Const (First Player))) g) => 78 | (g -> Position -> IO ()) 79 | -> g 80 | -> IO () 81 | permove k g = 82 | let t = whoseTurn g 83 | in do putStrLn (showWithoutPositions g) 84 | mapM_ putStrLn 85 | [ 86 | showPlayer t ++ " to move" 87 | , " * [1-9] to Move" 88 | , " * q to Quit" 89 | , " * v to view positions" 90 | ] 91 | c <- getChar 92 | putStrLn [] 93 | putStrLn "--------------------------------" 94 | putStrLn [] 95 | if c `elem` "vV" 96 | then 97 | do putStrLn (showWithPositions g) 98 | permove k g 99 | else 100 | if c `elem` "qQ" 101 | then 102 | putStrLn "Cheerio" 103 | else 104 | case c ^? _Position of 105 | Nothing -> do putStrLn ("Invalid selection '" ++ c : "'. Please try again.") 106 | permove k g 107 | Just p -> k g p 108 | 109 | showPlayer :: 110 | Player 111 | -> String 112 | showPlayer t = 113 | "Player " ++ show (_Player # t :: Int) ++ " [" ++ show t ++ "]" 114 | 115 | showPositionsUnoccupied :: 116 | AsPosition (->) (IndexingN Player (Const (First Player))) g => 117 | (Position -> String) 118 | -> g 119 | -> String 120 | showPositionsUnoccupied f g = 121 | showEachPosition (\p -> case positionPlayer p g of 122 | Nothing -> f p 123 | Just q -> show q) 124 | 125 | showWithPositions :: 126 | AsPosition (->) (IndexingN Player (Const (First Player))) g => 127 | g 128 | -> String 129 | showWithPositions = 130 | showPositionsUnoccupied (\p -> show (_Position # p :: Int)) 131 | 132 | showWithoutPositions :: 133 | AsPosition (->) (IndexingN Player (Const (First Player))) g => 134 | g 135 | -> String 136 | showWithoutPositions = 137 | showPositionsUnoccupied (const " ") 138 | 139 | -- | Shows a board using ASCII notation and substituting the returned string for each position. 140 | showEachPosition :: 141 | (Position -> String) -- ^ The function returning the string to substitute each position. 142 | -> String 143 | showEachPosition k = 144 | let z = ".===.===.===." 145 | e = [ 146 | z 147 | , concat ["| ", k P1, " | ", k P2, " | ", k P3, " |"] 148 | , z 149 | , concat ["| ", k P4, " | ", k P5, " | ", k P6, " |"] 150 | , z 151 | , concat ["| ", k P7, " | ", k P8, " | ", k P9, " |"] 152 | , z 153 | ] 154 | in intercalate "\n" e 155 | -------------------------------------------------------------------------------- /projects/TicTacToe/java/src/tictactoe/Main.java: -------------------------------------------------------------------------------- 1 | package tictactoe; 2 | 3 | import fj.*; 4 | import fj.data.Option; 5 | 6 | import static fj.Unit.unit; 7 | import static fj.data.Option.some; 8 | import static java.lang.System.out; 9 | 10 | public final class Main { 11 | private Main() {} 12 | 13 | private static void surround(P1 e) { 14 | out.println(); 15 | out.println(); 16 | e._1(); 17 | out.println(); 18 | } 19 | 20 | private static void printBoard(final F inheritance, final B b, final F empty) { 21 | surround(new P1() { 22 | public Unit _1() { 23 | out.println(inheritance.f(b).toString(new F2, Position, Character>() { 24 | public Character f(final Option pl, final Position pos) { 25 | return pl.option(empty.f(pos), Player.toSymbol); 26 | } 27 | })); 28 | return unit(); 29 | } 30 | }); 31 | } 32 | 33 | private static void printBoardSpaces(final F inheritance, final B b) { 34 | printBoard(inheritance, b, Function.constant(' ')); 35 | } 36 | 37 | private static Option readChar() { 38 | final String line = System.console().readLine(); 39 | return line.isEmpty() ? Option.none() : some(line.charAt(0)); 40 | } 41 | 42 | private static void gameLoop(final F inheritance, final F2 move, final B b) { 43 | final Player p = inheritance.f(b).whoseTurn(); 44 | out.println(p + " to move [" + p.toSymbol() + "]"); 45 | out.println(" [1-9] to Move"); 46 | out.println(" q to Quit"); 47 | out.println(" v to view board positions"); 48 | out.print(" > "); 49 | 50 | readChar().option(new P1() { 51 | public Unit _1() { 52 | out.println("Please make a selection."); 53 | gameLoop(inheritance, move, b); 54 | return unit(); 55 | } 56 | }, new F() { 57 | public Unit f(final Character c) { 58 | if(c == 'v' || c == 'V') { 59 | printBoard(inheritance, b, Position.toChar); 60 | gameLoop(inheritance, move, b); 61 | return unit(); 62 | } else { 63 | return Position.fromChar(c).option(new P1() { 64 | public Unit _1() { 65 | if(c == 'q' || c == 'Q') 66 | out.println("Bye!"); 67 | else { 68 | out.println("Invalid selection. Please try again."); 69 | gameLoop(inheritance, move, b); 70 | } 71 | return unit(); 72 | } 73 | }, new F() { 74 | public Unit f(final Position d) { 75 | return move.f(d, b); 76 | } 77 | }); 78 | } 79 | } 80 | }); 81 | 82 | } 83 | 84 | private static final F boardInheritance = new F() { 85 | public BoardLike f(final Board board) { 86 | return board; 87 | } 88 | }; 89 | 90 | private static final F finishedBoardInheritance = new F() { 91 | public BoardLike f(final Board.FinishedBoard board) { 92 | return board; 93 | } 94 | }; 95 | 96 | private static final F emptyBoardInheritance = new F() { 97 | public BoardLike f(final Board.EmptyBoard board) { 98 | return board; 99 | } 100 | }; 101 | 102 | private static void tictactoeBoard(final Board b) { 103 | gameLoop(boardInheritance, new F2() { 104 | public Unit f(final Position p, final Board bb) { 105 | return bb.moveTo(p).fold( 106 | new P1() { 107 | public Unit _1() { 108 | out.println("That position is already taken. Try again."); 109 | printBoardSpaces(boardInheritance, bb); 110 | out.println(); 111 | tictactoeBoard(bb); 112 | return unit(); 113 | } 114 | } 115 | , new F() { 116 | public Unit f(final Board bbb) { 117 | surround(new P1() { 118 | public Unit _1() { 119 | printBoardSpaces(boardInheritance, bbb); 120 | return unit(); 121 | } 122 | }); 123 | tictactoeBoard(bbb); 124 | return unit(); 125 | } 126 | } 127 | , new F() { 128 | public Unit f(final Board.FinishedBoard bbb) { 129 | surround(new P1() { 130 | public Unit _1() { 131 | printBoardSpaces(finishedBoardInheritance, bbb); 132 | out.println(bbb.result().strictFold("Player 1 Wins!", "Player 2 Wins!", "Draw")); 133 | return unit(); 134 | } 135 | }); 136 | return unit(); 137 | } 138 | } 139 | ); 140 | } 141 | }, b); 142 | } 143 | 144 | public static void main(final String... args) { 145 | gameLoop( 146 | emptyBoardInheritance 147 | , new F2() { 148 | public Unit f(final Position p, final Board.EmptyBoard b) { 149 | final Board bb = b.moveTo(p); 150 | surround(new P1() { 151 | public Unit _1() { 152 | printBoardSpaces(boardInheritance, bb); 153 | return unit(); 154 | } 155 | }); 156 | tictactoeBoard(bb); 157 | return unit(); 158 | } 159 | } 160 | , Board.EmptyBoard.empty() 161 | ); 162 | } 163 | } 164 | --------------------------------------------------------------------------------