├── 0001Hangman ├── Setup.hs ├── Main.hs ├── test │ └── doctests.hs ├── Hangman.cabal ├── README.markdown ├── words.txt └── Hangman.hs ├── 0004AmISick ├── MedicalAdvice │ ├── Advisors.hs │ ├── Patient.hs │ ├── Lib.hs │ ├── Illnesses.hs │ ├── Advice.hs │ ├── Measurements.hs │ ├── Facts.hs │ └── Questions.hs ├── CallCenter │ └── Main.hs └── README.md ├── 0005Tetris ├── Setup.hs ├── src │ ├── Main.hs │ ├── Engine.hs │ └── Game.hs └── Tetris.cabal ├── sudoku.png ├── .gitignore ├── LICENSE ├── README.markdown ├── 0002Quadtree.hs ├── index.html ├── 0003Sudoku.hs └── process.js /0001Hangman/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Advisors.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Advisors where 2 | -------------------------------------------------------------------------------- /0005Tetris/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /sudoku.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ToJans/learninghaskell/HEAD/sudoku.png -------------------------------------------------------------------------------- /0001Hangman/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Hangman (hangmanGame) 4 | 5 | main :: IO () 6 | main = hangmanGame "words.txt" 7 | -------------------------------------------------------------------------------- /0001Hangman/test/doctests.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Test.DocTest 4 | 5 | main :: IO () 6 | main = doctest ["-isrc", "Hangman.hs"] 7 | -------------------------------------------------------------------------------- /0005Tetris/src/Main.hs: -------------------------------------------------------------------------------- 1 | import Engine 2 | import Game 3 | 4 | main :: IO () 5 | main = runEngine initLevel eventHandler timeStepHandler 6 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Patient.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Patient where 2 | 3 | import MedicalAdvice.Facts 4 | 5 | newtype PatientId = PatientId String 6 | 7 | data Patient = Patient PatientId [Fact] 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .virtualenv 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Lib.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Lib where 2 | 3 | import System.Random (randomRIO) 4 | 5 | pickRandom :: [a] -> IO a 6 | pickRandom l = do 7 | idx <- randomRIO (0,length l - 1) 8 | return $ l !! idx 9 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Illnesses.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Illnesses where 2 | 3 | import MedicalAdvice.Lib 4 | 5 | data Illness = Illness String deriving Show 6 | 7 | getRandomIllness :: IO Illness 8 | getRandomIllness = pickRandom $ map Illness [ "cold" 9 | , "flue" 10 | , "rash" 11 | , "allergy" 12 | ] 13 | -------------------------------------------------------------------------------- /0004AmISick/CallCenter/Main.hs: -------------------------------------------------------------------------------- 1 | module CallCenter.Main where 2 | 3 | 4 | type Name = String 5 | 6 | data Call = IncomingCall Nurse 7 | | CustomerCall Customer 8 | | DiagnosedCall Nurse Patient 9 | | StaffCall Nurse Patient MedicalStaff 10 | 11 | -- AR : contactData 12 | data ContactData = Contact Name String 13 | 14 | data Nurse = Nurse ContactData 15 | 16 | data Customer = Customer ContactData 17 | 18 | data MedicalStaff = MedicalStaff ContactData 19 | 20 | data Patient = Patient ContactData 21 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Advice.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Advice where 2 | 3 | import MedicalAdvice.Lib 4 | 5 | data Advice = Suggestion String 6 | | SuggestMedicalStaffVisit 7 | | ContactMedicalStaff 8 | deriving Show 9 | 10 | 11 | getRandomAdvice :: IO Advice 12 | getRandomAdvice = pickRandom 13 | [ Suggestion "Eat more" 14 | , Suggestion "Eat less" 15 | , Suggestion "Exercise more" 16 | , Suggestion "Exercise less" 17 | , SuggestMedicalStaffVisit 18 | , ContactMedicalStaff 19 | ] 20 | -------------------------------------------------------------------------------- /0004AmISick/README.md: -------------------------------------------------------------------------------- 1 | Let's see if we can tackle a DDD-ish problem in Haskell 2 | 3 | taken from http://architecturalkatas.site44.com/kata.html?kata=AmISick.json 4 | 5 | 1-800-AMI-SICK 6 | Your company wants to build a software system supporting call center nurses 7 | (advice nurse) answering questions from customers about potential health problems. 8 | 9 | Projected users: 250+ nurses worldwide 10 | 11 | Requirements: access patient medical histories; assist nurses in providing medical 12 | diagnosis; enable client customers to reach local medical staff (if necessary), 13 | contacting the local medical staff directly ahead of time (if necessary) 14 | 15 | Later phase requirements: enable parts of the system for direct client customer use 16 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Measurements.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Measurements where 2 | 3 | import Control.Monad (join) 4 | import MedicalAdvice.Lib 5 | import System.Random (randomRIO) 6 | 7 | data Measurement = Length Double 8 | | Weight Double 9 | | Temperature Double 10 | | Pulse Int Int 11 | deriving Show 12 | 13 | getRandomMeasurement :: IO Measurement 14 | getRandomMeasurement = join $ pickRandom [ Length <$> randomRIO (140,210) 15 | , Weight <$> randomRIO (50,200) 16 | , Temperature <$> randomRIO (35,42) 17 | , Pulse <$> randomRIO (10,20) <*> randomRIO (5,10) 18 | ] 19 | -------------------------------------------------------------------------------- /0005Tetris/Tetris.cabal: -------------------------------------------------------------------------------- 1 | -- Initial Tetris.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: Tetris 5 | version: 0.1.0.0 6 | synopsis: A simple Tetris game to learn Haskell 7 | -- description: 8 | license: PublicDomain 9 | license-file: LICENSE 10 | author: Tom Janssens 11 | maintainer: Tom@corebvba.be 12 | -- copyright: 13 | category: Game 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | executable Tetris 19 | main-is: Main.hs 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.8 && <4.9 23 | , gloss >=1.9 && <1.10 24 | , random >= 1.1 && < 2 25 | hs-source-dirs: src 26 | default-language: Haskell2010 27 | -------------------------------------------------------------------------------- /0001Hangman/Hangman.cabal: -------------------------------------------------------------------------------- 1 | -- Initial Hangman.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: Hangman 5 | version: 0.1.0.0 6 | synopsis: Hangman game 7 | -- description: 8 | license: PublicDomain 9 | license-file: LICENSE 10 | author: Tom Janssens 11 | maintainer: Tom@corebvba.be 12 | -- copyright: 13 | category: Game 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | data-files: words.txt 18 | 19 | executable Hangman 20 | main-is: Main.hs 21 | other-modules: Hangman 22 | -- other-extensions: 23 | build-depends: base >=4.8 && <4.9, random >=1.1 && <1.2 24 | -- hs-source-dirs: 25 | default-language: Haskell2010 26 | 27 | test-suite doctests 28 | type: exitcode-stdio-1.0 29 | hs-source-dirs: test 30 | main-is: doctests.hs 31 | ghc-options: -threaded 32 | build-depends: base, doctest 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This is free and unencumbered software released into the public domain. 2 | 3 | Anyone is free to copy, modify, publish, use, compile, sell, or 4 | distribute this software, either in source code form or as a compiled 5 | binary, for any purpose, commercial or non-commercial, and by any 6 | means. 7 | 8 | In jurisdictions that recognize copyright laws, the author or authors 9 | of this software dedicate any and all copyright interest in the 10 | software to the public domain. We make this dedication for the benefit 11 | of the public at large and to the detriment of our heirs and 12 | successors. We intend this dedication to be an overt act of 13 | relinquishment in perpetuity of all present and future rights to this 14 | software under copyright law. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR 20 | OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, 21 | ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 22 | OTHER DEALINGS IN THE SOFTWARE. 23 | 24 | For more information, please refer to 25 | 26 | -------------------------------------------------------------------------------- /0001Hangman/README.markdown: -------------------------------------------------------------------------------- 1 | # Hangman game 2 | 3 | This is an exercise to learn Haskell, and to see how `haddock` and `doctests` work. 4 | 5 | In real life it probably wouldn't make sense to expose every single function in 6 | the `Hangman` module, but for the purpose of learning how to write documentation 7 | and use doctests, I've done it anyway. 8 | 9 | This should also be a good example about how literate docs need to be to be 10 | usable by Haskell noobs like me. 11 | 12 | You can find the generated docs [here](http://users.telenet.be/bull/learninghaskell/0001Hangman/Hangman.html). 13 | 14 | ## Installation 15 | 16 | Make sure you have `git`, `Haskell` and `cabal` installed. 17 | 18 | ``` 19 | git clone https://github.com/ToJans/learninghaskell.git 20 | cd learninghaskell/0001Hangman 21 | cabal sandbox init 22 | cabal install --dependencies-only 23 | ``` 24 | ## Running the game 25 | 26 | ``` 27 | cabal run 28 | ``` 29 | 30 | ## Generating docs 31 | 32 | ``` 33 | cabal haddock --executable 34 | ``` 35 | 36 | You can find the docs in the `dist/doc/html/Hangman/Hangman` folder. 37 | 38 | ## Running the doctests 39 | 40 | This will run all the examples specified in the docs and verify 41 | it's outcome with that in the documentation. 42 | 43 | ``` 44 | cabal test 45 | ``` 46 | -------------------------------------------------------------------------------- /README.markdown: -------------------------------------------------------------------------------- 1 | # Learning Haskell 2 | 3 | Some random exercises I perform in order to get a better grasp on Haskell. 4 | 5 | Goals: 6 | - readable code 7 | - type-driven development 8 | - real-world cases, not some abstract mumbo-jumbo 9 | 10 | ## Running it 11 | 12 | Just do `runhaskell x` to run an exercise in the main folder; for example: 13 | 14 | ``` 15 | E:\Dev\haskell\learning>runhaskell "0003 Sudoku.hs" 16 | Sudoku solver by @ToJans 17 | 18 | |-----------------------| 19 | | 4 . 3 | 1 . . | 9 . 8 | 20 | | . 2 9 | . . . | 4 5 . | 21 | | 1 7 . | 8 4 9 | . . . | 22 | |-----------------------| 23 | | . 4 . | . 2 . | . . . | 24 | | . 9 . | 4 . 7 | . 3 . | 25 | | . . . | . 3 . | . 8 . | 26 | |-----------------------| 27 | | . . . | 5 9 8 | . 4 7 | 28 | | . 5 7 | . . . | 8 6 . | 29 | | 2 . 4 | . . 3 | 5 . 9 | 30 | |-----------------------| 31 | 32 | Finding solution 33 | BoardSolved 34 | |-----------------------| 35 | | 4 6 3 | 1 5 2 | 9 7 8 | 36 | | 8 2 9 | 3 7 6 | 4 5 1 | 37 | | 1 7 5 | 8 4 9 | 3 2 6 | 38 | |-----------------------| 39 | | 3 4 8 | 6 2 1 | 7 9 5 | 40 | | 5 9 6 | 4 8 7 | 1 3 2 | 41 | | 7 1 2 | 9 3 5 | 6 8 4 | 42 | |-----------------------| 43 | | 6 3 1 | 5 9 8 | 2 4 7 | 44 | | 9 5 7 | 2 1 4 | 8 6 3 | 45 | | 2 8 4 | 7 6 3 | 5 1 9 | 46 | |-----------------------| 47 | 48 | 49 | E:\Dev\haskell\learning> 50 | ``` 51 | 52 | To run exercises in the sub folders, you need to install `cabal`. 53 | Then you just go into the subfolder and type `cabal run` or `cabal repl`. 54 | If you get an error message about missing dependencies, you should probably run 55 | `cabal install --dependencies-only`. 56 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Facts.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Facts where 2 | 3 | import Control.Monad (join, replicateM) 4 | import Data.Time (Day, addDays, getCurrentTime, 5 | utctDay) 6 | import MedicalAdvice.Advice (Advice, getRandomAdvice) 7 | import MedicalAdvice.Illnesses (Illness, getRandomIllness) 8 | import MedicalAdvice.Lib 9 | import MedicalAdvice.Measurements (Measurement, getRandomMeasurement) 10 | import MedicalAdvice.Questions (QuestionAnswer, 11 | getRandomQuestionAnswer) 12 | import System.Random (randomRIO) 13 | 14 | type Date = Day 15 | 16 | data Fact = Fact Occurance FactType deriving Show 17 | 18 | data Occurance = Occurance 19 | { fromDate :: Maybe Date 20 | , toDate :: Maybe Date 21 | } deriving Show 22 | 23 | 24 | data FactType = Measurement Measurement 25 | | Diagnosis Illness 26 | | Advice Advice 27 | | QuestionAnswer QuestionAnswer 28 | deriving Show 29 | 30 | getRandomOccurance :: IO Occurance 31 | getRandomOccurance = do 32 | now <- utctDay <$> getCurrentTime 33 | deltaFrom <- randomRIO (1,365*10) 34 | deltaTo <- randomRIO (0,deltaFrom) 35 | fromD <- pickRandom [Nothing, Just $ addDays (-deltaFrom) now] 36 | toD <- pickRandom [Nothing, Just $ addDays (-deltaTo) now] 37 | return $ Occurance fromD toD 38 | 39 | getRandomFact :: IO Fact 40 | getRandomFact = do 41 | f <- join $ pickRandom [ Measurement <$> getRandomMeasurement 42 | , Diagnosis <$> getRandomIllness 43 | , Advice <$> getRandomAdvice 44 | , QuestionAnswer <$> getRandomQuestionAnswer 45 | ] 46 | occ <- getRandomOccurance 47 | return $ Fact occ f 48 | 49 | getRandomFacts :: IO [Fact] 50 | getRandomFacts = do 51 | amnt <- randomRIO (30,50) 52 | replicateM amnt getRandomFact 53 | -------------------------------------------------------------------------------- /0005Tetris/src/Engine.hs: -------------------------------------------------------------------------------- 1 | module Engine(runEngine) where 2 | 3 | import Game 4 | import Graphics.Gloss 5 | import Graphics.Gloss.Interface.IO.Game 6 | 7 | cellSize :: Int 8 | cellSize = 30; 9 | 10 | drawBlock :: Position -> Block -> Picture 11 | drawBlock p b = Pictures $ map drawCell $ blockToCells p b 12 | 13 | drawCell :: Cell -> Picture 14 | drawCell (Cell blockcolor (Position xi yi)) = Color (getColor blockcolor) poly 15 | where 16 | [x,y,cs] = map fromIntegral [xi*cellSize,yi*cellSize,cellSize-1] 17 | poly = Polygon [(x,y), (x+cs,y), (x+cs,y+cs), (x,y+cs)] 18 | getColor c = case c of 19 | Red -> red 20 | Green -> green 21 | Blue -> blue 22 | Yellow -> yellow 23 | Cyan -> cyan 24 | Orange -> orange 25 | Magenta -> magenta 26 | 27 | drawLevel :: Level -> Picture 28 | drawLevel (Level board state score) = 29 | Pictures $ drawBoard board : drawState state ++ [drawScore] 30 | where 31 | drawScore = alignEtc 550 $ " Score: " ++ show score 32 | drawBoard (Board cells)= Pictures $ map drawCell cells 33 | drawState (BlockFalling pos block) = [drawBlock pos block] 34 | drawState (GameOver) = 35 | [ alignEtc 300 "Game over" 36 | , alignEtc 250 "Press space to restart" 37 | ] 38 | drawState _ = [] 39 | alignEtc y = Color white . Translate 0 y . Scale 0.2 0.2 . Text 40 | 41 | runEngine :: Level -> (LevelEvent -> Level -> IO Level) -> (Float -> Level -> IO Level) -> IO () 42 | runEngine wrld eventHandler = 43 | playIO window black 44 | 4 -- simulations/sec 45 | wrld 46 | drawWrld 47 | internalEventHandler 48 | where 49 | window = InWindow "HaskTris by @ToJans" (w, h) (100, 100) 50 | w = cellSize * gridWidth 51 | h = cellSize * gridHeight 52 | drawWrld wrld = return 53 | $ translate (-fromIntegral w/2) (-fromIntegral h/2) 54 | $ drawLevel wrld 55 | internalEventHandler:: Event -> Level -> IO Level 56 | internalEventHandler evt = maybe return eventHandler $ maybeEvent evt 57 | maybeEvent evt = case evt of 58 | EventKey (SpecialKey KeyLeft) Down _ _ -> Just MoveBlockLeft 59 | EventKey (SpecialKey KeyRight) Down _ _ -> Just MoveBlockRight 60 | EventKey (SpecialKey KeyUp) Down _ _ -> Just RotateBlock 61 | EventKey (SpecialKey KeyDown) Down _ _ -> Just MoveBlockDown 62 | EventKey (SpecialKey KeySpace) Down _ _ -> Just RestartGame 63 | otherwise -> Nothing 64 | -------------------------------------------------------------------------------- /0004AmISick/MedicalAdvice/Questions.hs: -------------------------------------------------------------------------------- 1 | module MedicalAdvice.Questions where 2 | 3 | import MedicalAdvice.Lib 4 | import System.Random (randomRIO) 5 | 6 | data Question = Question String QuestionType 7 | deriving Show 8 | 9 | data QuestionType = OccuranceQuestion 10 | | BoolQuestion 11 | | ChoiceQuestion [String] 12 | | NumberQuestion { minRange :: Int, maxRange :: Int} 13 | | TextQuestion 14 | deriving Show 15 | 16 | data Answer = OccuranceAnswer 17 | | BoolAnswer Bool 18 | | TextAnswer String 19 | | NumberAnswer Int 20 | deriving Show 21 | 22 | data QuestionAnswer = QuestionAnswer Question Answer 23 | deriving Show 24 | 25 | 26 | questionType :: Question -> QuestionType 27 | questionType (Question _ t) = t 28 | 29 | getRandomQuestion :: IO Question 30 | getRandomQuestion = pickRandom [ Question "When do you take your pills" OccuranceQuestion 31 | , Question "Do you feel tired in the evening" BoolQuestion 32 | , Question "What is your favorite color" $ ChoiceQuestion ["red","green","blue"] 33 | , Question "How much beers do you drink per day" $ NumberQuestion 0 40 34 | , Question "How do you feel about your partner" TextQuestion 35 | ] 36 | 37 | 38 | getRandomQuestionAnswer :: IO QuestionAnswer 39 | getRandomQuestionAnswer = do 40 | q <- getRandomQuestion 41 | qa <- case questionType q of 42 | OccuranceQuestion -> return OccuranceAnswer 43 | BoolQuestion -> pickRandom $ map BoolAnswer [True,False] 44 | ChoiceQuestion choices -> pickRandom $ map TextAnswer choices 45 | NumberQuestion minv maxv -> NumberAnswer <$> randomRIO (minv,maxv) 46 | TextQuestion -> pickRandom $ map TextAnswer [ "Aaahw!!!! I feel good!" 47 | , "She's always a woman to me" 48 | , "I'm in love with an alien" 49 | , "Billy Jean is not my love" 50 | ] 51 | return $ QuestionAnswer q qa 52 | -------------------------------------------------------------------------------- /0001Hangman/words.txt: -------------------------------------------------------------------------------- 1 | aardvark 2 | addax 3 | alligator 4 | alpaca 5 | anteater 6 | antelope 7 | aoudad 8 | ape 9 | argali 10 | armadillo 11 | ass 12 | baboon 13 | badger 14 | basilisk 15 | bat 16 | bear 17 | beaver 18 | bighorn 19 | bison 20 | boar 21 | budgerigar 22 | buffalo 23 | bull 24 | bunny 25 | burro 26 | camel 27 | canary 28 | capybara 29 | cat 30 | chameleon 31 | chamois 32 | cheetah 33 | chimpanzee 34 | chinchilla 35 | chipmunk 36 | civet 37 | coati 38 | colt 39 | cony 40 | cougar 41 | cow 42 | coyote 43 | crocodile 44 | crow 45 | deer 46 | dingo 47 | doe 48 | dog 49 | donkey 50 | dormouse 51 | dromedary 52 | duckbill 53 | dugong 54 | eland 55 | elephant 56 | elk 57 | ermine 58 | ewe 59 | fawn 60 | ferret 61 | finch 62 | fish 63 | fox 64 | frog 65 | gazelle 66 | gemsbok 67 | gila 68 | monster 69 | giraffe 70 | gnu 71 | goat 72 | gopher 73 | gorilla 74 | grizzly 75 | bear 76 | ground 77 | hog 78 | guanaco 79 | guinea 80 | pig 81 | hamster 82 | hare 83 | hartebeest 84 | hedgehog 85 | hippopotamus 86 | hog 87 | horse 88 | hyena 89 | ibex 90 | iguana 91 | impala 92 | jackal 93 | jaguar 94 | jerboa 95 | kangaroo 96 | kid 97 | kinkajou 98 | kitten 99 | koala 100 | koodoo 101 | lamb 102 | lemur 103 | leopard 104 | lion 105 | lizard 106 | llama 107 | lovebird 108 | lynx 109 | mandrill 110 | mare 111 | marmoset 112 | marten 113 | mink 114 | mole 115 | mongoose 116 | monkey 117 | moose 118 | mountain 119 | goat 120 | mouse 121 | mule 122 | musk 123 | deer 124 | musk-ox 125 | muskrat 126 | mustang 127 | mynah 128 | bird 129 | newt 130 | ocelot 131 | okapi 132 | opossum 133 | orangutan 134 | oryx 135 | otter 136 | ox 137 | panda 138 | panther 139 | parakeet 140 | parrot 141 | peccary 142 | pig 143 | platypus 144 | polar 145 | bear 146 | pony 147 | porcupine 148 | porpoise 149 | prairie 150 | dog 151 | pronghorn 152 | puma 153 | puppy 154 | quagga 155 | rabbit 156 | raccoon 157 | ram 158 | rat 159 | reindeer 160 | reptile 161 | rhinoceros 162 | roebuck 163 | salamander 164 | seal 165 | sheep 166 | shrew 167 | silver 168 | fox 169 | skunk 170 | sloth 171 | snake 172 | springbok 173 | squirrel 174 | stallion 175 | steer 176 | tapir 177 | tiger 178 | toad 179 | turtle 180 | vicuna 181 | walrus 182 | warthog 183 | waterbuck 184 | weasel 185 | whale 186 | wildcat 187 | wolf 188 | wolverine 189 | wombat 190 | woodchuck 191 | yak 192 | zebra 193 | zebu 194 | -------------------------------------------------------------------------------- /0002Quadtree.hs: -------------------------------------------------------------------------------- 1 | -- A quadtree implementation by @ToJans 2 | -- 3 | -- This example fills a quadtree with 20 random points, 4 | -- with a max of 3 points per node 5 | 6 | module Main where 7 | 8 | import Control.Monad (replicateM) 9 | import System.Random (randomRIO) 10 | 11 | data Point = Point Int Int 12 | deriving Show 13 | 14 | type LeafPointCount = Int 15 | 16 | data QuadTreeNode = Leaf [Point] 17 | | Node { nNW :: QuadTreeNode 18 | , nNE :: QuadTreeNode 19 | , nSW :: QuadTreeNode 20 | , nSE :: QuadTreeNode 21 | } 22 | 23 | data Bounds = Bounds { bLeft :: Int 24 | , bTop :: Int 25 | , bRight :: Int 26 | , bBottom :: Int 27 | } deriving Show 28 | 29 | data QuadTree = QuadTree { qtBounds :: Bounds 30 | , qtMaxLeafPoints :: LeafPointCount 31 | , qtRoot :: QuadTreeNode 32 | } 33 | 34 | instance Show QuadTree where 35 | show (QuadTree bnds maxc nodes) = "Bounds: " ++ show bnds 36 | ++ "\nMax points per node: " ++ show maxc 37 | ++ "\nNodes:\n" ++ show nodes 38 | 39 | instance Show QuadTreeNode where 40 | show (Leaf points) = "Leaf: " ++ show points 41 | show (Node nw ne sw se) = padl $ "\nNW: " ++ show nw 42 | ++ "\nNE: " ++ show ne 43 | ++ "\nSW: " ++ show sw 44 | ++ "\nSE: " ++ show se 45 | where padl = unlines . map (" " ++) . lines 46 | 47 | isInBounds :: Bounds -> Point -> Bool 48 | isInBounds (Bounds l t r b) (Point x y) = x >= l && y >= t && x <= r && y <= b 49 | 50 | subdivideBounds :: Bounds -> (Bounds,Bounds,Bounds,Bounds) 51 | subdivideBounds (Bounds l t r b) = 52 | ( Bounds l t cx cy 53 | , Bounds cx t r cy 54 | , Bounds l cy cx b 55 | , Bounds cx cy r b 56 | ) 57 | where cx = (l+r) `div` 2 58 | cy = (t+b) `div` 2 59 | 60 | emptyTree :: Bounds -> LeafPointCount -> QuadTree 61 | emptyTree bounds maxLeafPoints = QuadTree bounds maxLeafPoints (Leaf []) 62 | 63 | splitNode :: QuadTreeNode -> Bounds -> QuadTreeNode 64 | splitNode (Leaf pts) bnds = 65 | let (nwb,neb,swb,seb) = subdivideBounds bnds in 66 | Node (leafInBounds nwb) 67 | (leafInBounds neb) 68 | (leafInBounds swb) 69 | (leafInBounds seb) 70 | where leafInBounds b = Leaf $ filter (isInBounds b) pts 71 | splitNode other _ = other 72 | 73 | pushPointToTree :: QuadTree -> Point -> QuadTree 74 | pushPointToTree (QuadTree b maxc node) point = 75 | QuadTree b maxc $ maybeAddPointToNode node b 76 | where maybeAddPointToNode n bnds = 77 | if isInBounds bnds point 78 | then addPointToNode n bnds 79 | else n 80 | addPointToNode (Leaf pts) bnds = 81 | if length pts > maxc 82 | then addPointToNode (splitNode (Leaf pts) bnds ) bnds 83 | else Leaf $ point:pts 84 | addPointToNode (Node nw ne sw se) bnds = 85 | let (bnw,bne,bsw,bse) = subdivideBounds bnds in 86 | Node (maybeAddPointToNode nw bnw) 87 | (maybeAddPointToNode ne bne) 88 | (maybeAddPointToNode sw bsw) 89 | (maybeAddPointToNode se bse) 90 | 91 | pushPointsToTree :: QuadTree -> [Point] -> QuadTree 92 | pushPointsToTree = foldl pushPointToTree 93 | 94 | randomPoint :: Bounds -> IO Point 95 | randomPoint (Bounds l t r b) = do 96 | x <- randomRIO (l, r) 97 | y <- randomRIO (t, b) 98 | return (Point x y) 99 | 100 | randomPoints :: Bounds -> Int -> IO [Point] 101 | randomPoints bnds cnt = replicateM cnt $ randomPoint bnds 102 | 103 | main :: IO () 104 | main = do 105 | let bounds = Bounds 0 0 1000 1000 106 | let emptytree = emptyTree bounds 3 107 | points <- randomPoints bounds 20 108 | let tree = pushPointsToTree emptytree points 109 | print tree 110 | 111 | -- OUTPUT 112 | -- E:\Dev\haskell\learning>runghc "0002 Quadtree.hs" 113 | -- 0002 Quadtree.hs: warning: _tzset from msvcrt is linked instead of __imp__tzset 114 | -- Bounds: Bounds {bLeft = 0, bTop = 0, bRight = 1000, bBottom = 1000} 115 | -- Max points per node: 3 116 | -- Nodes: 117 | -- 118 | -- NW: Leaf: [Point 196 178,Point 86 330] 119 | -- NE: 120 | -- NW: Leaf: [Point 560 43,Point 618 28,Point 550 0,Point 576 185] 121 | -- NE: Leaf: [Point 817 78] 122 | -- SW: Leaf: [Point 593 371] 123 | -- SE: Leaf: [Point 946 339,Point 792 313,Point 830 364] 124 | -- 125 | -- SW: 126 | -- NW: Leaf: [] 127 | -- NE: Leaf: [Point 346 515,Point 378 708] 128 | -- SW: Leaf: [Point 28 951,Point 51 904] 129 | -- SE: Leaf: [Point 366 807] 130 | -- 131 | -- SE: Leaf: [Point 721 526,Point 944 685,Point 502 796,Point 770 661] 132 | -- 133 | -- 134 | -- E:\Dev\haskell\learning> 135 | -------------------------------------------------------------------------------- /0005Tetris/src/Game.hs: -------------------------------------------------------------------------------- 1 | module Game where 2 | 3 | import Data.List(transpose) 4 | import System.Random(randomRIO) 5 | 6 | data Position = Position Int Int deriving (Eq, Show) 7 | 8 | data BlockColor = Red 9 | | Green 10 | | Blue 11 | | Yellow 12 | | Cyan 13 | | Orange 14 | | Magenta 15 | deriving (Bounded, Enum, Eq, Show) 16 | 17 | data Cell = Cell BlockColor Position deriving (Eq,Show) 18 | 19 | data Block = Block BlockColor [Position] deriving Show 20 | 21 | data Board = Board [Cell] 22 | 23 | data State = NewBlock 24 | | GameOver 25 | | BlockFalling Position Block 26 | deriving Show 27 | 28 | data Level = Level { 29 | lBoard :: Board, 30 | lState :: State, 31 | lScore :: Int 32 | } 33 | 34 | data LevelEvent = MoveBlockLeft 35 | | MoveBlockRight 36 | | MoveBlockDown 37 | | RotateBlock 38 | | RestartGame 39 | 40 | gridWidth :: Int 41 | gridWidth = 10 42 | 43 | gridHeight :: Int 44 | gridHeight = 20 45 | 46 | 47 | initLevel :: Level 48 | initLevel = Level emptyBoard NewBlock 0 49 | where 50 | emptyBoard = Board [] 51 | 52 | startPos :: Position 53 | startPos = Position (gridWidth `div` 2) (gridHeight - 1) 54 | 55 | -- Main loop 56 | timeStepHandler :: Float -> Level -> IO Level 57 | timeStepHandler _ts lvl@(Level board@(Board cells) state score) = 58 | case state of 59 | GameOver -> return lvl 60 | NewBlock -> do 61 | newBlock <- randomBlock 62 | return $ maybe (lvlState GameOver) blockFalling $ validate board startPos newBlock 63 | BlockFalling p@(Position x y) bl-> 64 | return $ maybe (mergeblock p bl) blockFalling $ validate board (Position x (y-1)) bl 65 | where 66 | lvlState x = lvl {lState = x} 67 | blockFalling (position,block) = lvlState $ BlockFalling position block 68 | mergeblock p b= Level (Board finalCells) NewBlock (score + scored) 69 | where 70 | newCells = cells ++ blockToCells p b 71 | finalCells = removeFullRows newCells 72 | linesRemoved = (length newCells - length finalCells) `div` gridWidth 73 | scored = case linesRemoved of 74 | 0 -> 0 75 | 1 -> 40 76 | 2 -> 100 77 | 3 -> 300 78 | _ -> 1200 79 | 80 | -- Main event handler 81 | eventHandler :: LevelEvent -> Level -> IO Level 82 | -- only works when a block is falling 83 | eventHandler evt lvl@(Level board (BlockFalling pos@(Position x y) block) score) = 84 | return $ maybe lvl blockFalling $ validate board p b 85 | where 86 | (p,b) = case evt of 87 | MoveBlockLeft -> (Position (x-1) y , block) 88 | MoveBlockRight -> (Position (x+1) y , block) 89 | MoveBlockDown -> (Position x (y-1), block) 90 | RotateBlock -> (Position x y , rotateBlock block) 91 | otherwise -> (pos,block) 92 | lvlState x = lvl {lState = x} 93 | blockFalling (position,block) = lvlState $ BlockFalling position block 94 | rotateBlock (Block color positions) = Block color $ map rotatePosition positions 95 | rotatePosition (Position x y) = Position y (-x) 96 | -- allow restart when game is over 97 | eventHandler RestartGame (Level _ GameOver _ ) = return initLevel 98 | -- ignore all the others 99 | eventHandler _ level = return level 100 | 101 | -- Returns a (Position,Block) if it is valid, otherwise Nothing 102 | validate :: Board -> Position -> Block -> Maybe (Position,Block) 103 | validate (Board cells) pos@(Position dx dy) bl@(Block color positions) = 104 | if any invalidPosition movedPositions 105 | then Nothing 106 | else Just (pos,bl) 107 | where 108 | movedPositions = map addPos positions 109 | addPos (Position x y) = Position (x+dx) (y+dy) 110 | invalidPosition p@(Position x y) = x < 0 || x > gridWidth - 1 || y < 0 || p `elem` cellPositions 111 | cellPositions = map cellPosition cells 112 | cellPosition (Cell _c p) = p 113 | 114 | -- Remove all rows that are complete and reindex the remaining rows 115 | removeFullRows :: [Cell] -> [Cell] 116 | removeFullRows cells = remapRows $ map selectIfNotFullRow [0..gridHeight-1] 117 | where 118 | selectRow r = filter (isCellInRow r) cells 119 | isCellInRow r (Cell _ (Position _x y)) = r == y 120 | selectIfNotFullRow r = 121 | let sr = selectRow r in 122 | if length sr == gridWidth 123 | then [] 124 | else sr 125 | remapRows = concat . zipWith (map . remapCell) [0..] . filter (not . null) 126 | remapCell i (Cell color (Position x _))= Cell color (Position x i) 127 | 128 | -- Convert a Block into board Cells 129 | blockToCells :: Position -> Block -> [Cell] 130 | blockToCells (Position dx dy) (Block clr positions) = 131 | map (Cell clr . movePos) positions 132 | where 133 | movePos (Position x y) = Position (x+dx) (y+dy) 134 | 135 | -- Return a random Block 136 | randomBlock :: IO Block 137 | randomBlock = do 138 | index <- randomRIO (0, length availableBlocks - 1) 139 | return $ availableBlocks !! index 140 | where 141 | availableBlocks = zipWith Block [minBound..] blockPositions 142 | blockPositions = map parseBlock blocks 143 | parseBlock = map tupleToPosition . filter notEmpty . list2dTo3Tuple 144 | list2dTo3Tuple = concat . zipWith (zip3 [0..] . repeat) [0..] 145 | tupleToPosition (x,y,_c) = Position (x - 1) (y-1) 146 | notEmpty (_x,_y,'█') = True 147 | notEmpty _ = False 148 | blocks = transpose . map words $ 149 | [ "_█ ██ ██ ███ ██ ██_ _██" 150 | , "_█ █_ _█ _█_ ██ _██ ██" 151 | , "_█ █_ _█" 152 | , "_█" 153 | ] 154 | -------------------------------------------------------------------------------- /index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 28 | 29 | 30 |

SUDOKU SOLVER by @ToJans from Arealities.com

31 | 32 |

Very early alpha version!!! Internet explorer is NOT supported!

33 | 34 |

Select an input image

35 |
36 |

Use an example image

37 | 38 | example sudoku image 39 |
40 | 45 |
46 |

Upload a sudoku picture from a file

47 | 48 |
49 | 54 |
55 |

Processed image

56 |
57 | 58 |
59 | 60 | 188 | 189 | -------------------------------------------------------------------------------- /0001Hangman/Hangman.hs: -------------------------------------------------------------------------------- 1 | -- | Hangman game by 2 | -- 3 | -- Allows you to guess random words letter by letter. 4 | -- If you have too many wrong attempts for one word, the man hangs, and the game 5 | -- is over. 6 | -- 7 | -- This is a learning experiment; more info at 8 | -- 9 | -- You can find the generated docs over . 10 | 11 | module Hangman where 12 | 13 | import Control.Monad (when) 14 | import Data.Char (toLower) 15 | import Data.List (transpose) 16 | import System.Random (randomRIO) 17 | 18 | -- | The state of the word to guess 19 | data WordState = WordState 20 | { _wordToGuess :: String -- ^ The word to guess 21 | , attempts :: String -- ^ The letters attempted 22 | } 23 | 24 | -- | The outcome of an attempt 25 | data AttemptOutcome = GuessAnotherLetter -- ^ Ready for another guess 26 | | WordGuessed -- ^ All the letters in the word were guessed 27 | | TooManyWrongAttempts -- ^ Too many wrong attempts 28 | deriving (Eq,Show) 29 | 30 | -- | The hangman ascii images for every wrong guess 31 | -- 32 | -- >>> putStrLn . unlines $ hangmanImages !! 6 33 | -- _O_ 34 | -- | 35 | -- / \ 36 | -- 37 | hangmanImages :: [[String]] 38 | hangmanImages = 39 | transpose 40 | [ [ " ", " O ", " O ", " O ", " O " , "_O " , "_O_" ] 41 | , [ " ", " ", " | ", " | ", " | " , " | " , " | " ] 42 | , [ " ", " ", " ", "/ ", "/ \\", "/ \\", "/ \\" ] 43 | ] 44 | 45 | -- | The hangman from a phase hanging on a pole 46 | -- 47 | -- >>> putStrLn . unlines $ fullHangmanImage 6 48 | -- ========= 49 | -- | | 50 | -- | _O_ 51 | -- | | 52 | -- | / \ 53 | -- 54 | fullHangmanImage :: Int -> [String] 55 | fullHangmanImage index = 56 | "=========" : 57 | "| |" : 58 | map ("| " ++) img 59 | where img = hangmanImages !! index 60 | 61 | -- | The max number of wrong attempts allowed. 62 | -- 63 | -- >>> maxWrongAttempts 64 | -- 6 65 | maxWrongAttempts :: Int 66 | maxWrongAttempts = length hangmanImages - 1 67 | 68 | -- | The current number of wrong attempts in a `WordState` 69 | -- 70 | -- >>> numberOfWrongAttempts $ WordState "cat" "" 71 | -- 0 72 | -- >>> numberOfWrongAttempts $ WordState "cat" "a" 73 | -- 0 74 | -- >>> numberOfWrongAttempts $ WordState "cat" "ab" 75 | -- 1 76 | -- >>> numberOfWrongAttempts $ WordState "cat" "abcdef" 77 | -- 4 78 | numberOfWrongAttempts :: WordState -> Int 79 | numberOfWrongAttempts (WordState word' attempts') = 80 | length $ filter charNotInWord attempts' 81 | where charNotInWord c = c `notElem` word' 82 | 83 | -- | What is the outcome of the last attempt? 84 | -- 85 | -- >>> lastAttemptOutcome $ WordState "cat" "" 86 | -- GuessAnotherLetter 87 | -- >>> lastAttemptOutcome $ WordState "cat" "abcd" 88 | -- GuessAnotherLetter 89 | -- >>> lastAttemptOutcome $ WordState "cat" "abcdefgh" 90 | -- TooManyWrongAttempts 91 | -- >>> lastAttemptOutcome $ WordState "cat" "abcdeft" 92 | -- WordGuessed 93 | lastAttemptOutcome :: WordState -> AttemptOutcome 94 | lastAttemptOutcome wordState@(WordState word' attempts') 95 | | isGuessed = WordGuessed 96 | | isLastGuess = TooManyWrongAttempts 97 | | otherwise = GuessAnotherLetter 98 | where 99 | isGuessed = all isCharInGuesses word' 100 | isCharInGuesses x = x `elem` attempts' 101 | isLastGuess = numberOfWrongAttempts wordState >= maxWrongAttempts 102 | 103 | -- | Get a `char` from `stdin`. 104 | -- For one reason or another `Prelude.getChar` also appends a carriage return, 105 | -- so I implemented my own and made sure empty input is refused. 106 | -- 107 | -- > >>> getAChar 108 | -- > <<< a 109 | -- > 'a' 110 | getAChar :: IO Char 111 | getAChar = do 112 | line <- getLine 113 | case line of 114 | [] -> getAChar 115 | (c:_) -> return c 116 | 117 | -- | Gets a letter that's not in the previous attempts for this word. 118 | -- 119 | -- > >>> getAValidAttempt $ WordState "cat" "abcd" 120 | -- > Next char to guess 121 | -- > <<< e 122 | -- > 'e' 123 | -- > >>> getAValidAttempt $ WordState "cat" "abcde" 124 | -- > Next char to guess 125 | -- > <<< d 126 | -- > Character already used in attempts. 127 | -- > Next char to guess 128 | -- > <<< f 129 | -- > 'f' 130 | getAValidAttempt :: WordState -> IO Char 131 | getAValidAttempt wordState = do 132 | putStrLn "Next char to guess" 133 | c <- getAChar 134 | if c `elem` attempts wordState 135 | then do 136 | putStrLn "Character already used in attempts." 137 | getAValidAttempt wordState 138 | else 139 | return c 140 | 141 | -- | Display the current state of the word. 142 | -- 143 | -- >>> printWordState $ WordState "cat" "" 144 | -- ========= 145 | -- | | 146 | -- | 147 | -- | 148 | -- | 149 | -- Word to guess: ___ 150 | -- 151 | -- Guesses: 152 | -- 153 | -- >>> printWordState $ WordState "cat" "abcd" 154 | -- ========= 155 | -- | | 156 | -- | O 157 | -- | | 158 | -- | 159 | -- Word to guess: ca_ 160 | -- 161 | -- Guesses: abcd 162 | -- 163 | -- >>> printWordState $ WordState "cat" "abcdeft" 164 | -- ========= 165 | -- | | 166 | -- | O 167 | -- | | 168 | -- | / \ 169 | -- CONGRATULATIONS! 170 | -- You correctly guessed the word cat 171 | -- in 7 tries 172 | -- 173 | -- >>> printWordState $ WordState "cat" "abcdefgh" 174 | -- ========= 175 | -- | | 176 | -- | _O_ 177 | -- | | 178 | -- | / \ 179 | -- YOU FAILED! 180 | -- You failed to guess the word cat 181 | -- 182 | printWordState :: WordState -> IO () 183 | printWordState wordState@(WordState word' attempts') = 184 | putStrLn $ unlines $ fullHangmanImage' ++ case lastAttemptOutcome wordState of 185 | GuessAnotherLetter -> 186 | [ "Word to guess: " ++ wordWithGuesses 187 | , "" 188 | , "Guesses: " ++ attempts' 189 | ] 190 | WordGuessed -> 191 | [ "CONGRATULATIONS!" 192 | , "You correctly guessed the word " ++ word' 193 | , " in " ++ show (length attempts') ++ " tries " 194 | ] 195 | TooManyWrongAttempts -> 196 | [ "YOU FAILED!" 197 | , "You failed to guess the word " ++ word' 198 | ] 199 | where 200 | fullHangmanImage' = fullHangmanImage currentHangmanIndex 201 | currentHangmanIndex = numberOfWrongAttempts wordState 202 | wordWithGuesses = blankOrChar <$> word' 203 | blankOrChar c 204 | | c `elem` attempts' = c 205 | | otherwise = '_' 206 | 207 | -- | Try to guess a word 208 | -- 209 | -- > >>> guessWord "dog" 210 | -- > ========= 211 | -- > | | 212 | -- > | 213 | -- > | 214 | -- > | 215 | -- > Word to guess: ___ 216 | -- > 217 | -- > Guesses: 218 | -- > 219 | -- > Next char to guess 220 | -- > <<< a 221 | -- > a 222 | -- > 223 | -- > ... 224 | -- > 225 | -- > ========= 226 | -- > | | 227 | -- > | O 228 | -- > | | 229 | -- > | 230 | -- > CONGRATULATIONS! 231 | -- > You correctly guessed the word dog 232 | -- > in 5 tries 233 | -- > 234 | guessWord :: String -> IO () 235 | guessWord word = guessLoop $ WordState word "" 236 | where 237 | guessLoop current@(WordState _word attempts) = do 238 | printWordState current 239 | when (lastAttemptOutcome current == GuessAnotherLetter) $ do 240 | c <- getAValidAttempt current 241 | guessLoop $ current { attempts = attempts ++ [c] } 242 | 243 | -- | Gets a random word from a textfile 244 | -- 245 | -- > >>> randomWord "words.txt" 246 | -- > "cat" 247 | -- > >>> randomWord "words.txt" 248 | -- > "monkey" 249 | randomWord :: FilePath -> IO String 250 | randomWord wordsPath = do 251 | contents <- readFile wordsPath 252 | let words' = filter validWord $ lines contents 253 | let wordcount = length words' 254 | randomNumber <- randomRIO (0,wordcount-1) 255 | let randomWord = words' !! randomNumber 256 | return randomWord 257 | where 258 | validWord word = 259 | '\'' `notElem` word && 260 | map toLower word == word 261 | 262 | -- | Play the hangman game using random words from the specified file 263 | -- 264 | -- > >>> hangmanGame "words.txt" 265 | -- > 266 | -- > ... 267 | -- > 268 | -- > YOU FAILED! 269 | -- > You failed to guess the word lizard 270 | -- > 271 | -- > Play again? (y/n): 272 | -- > y 273 | -- > 274 | -- > ... 275 | -- > 276 | -- > CONGRATULATIONS! 277 | -- > You correctly guessed the word hippopotamus 278 | -- > in 10 tries 279 | -- > 280 | -- > Play again? (y/n): 281 | -- > <<< n 282 | hangmanGame :: FilePath -> IO () 283 | hangmanGame wordsPath = do 284 | randomWord wordsPath >>= guessWord 285 | putStrLn "Play again? (y/n):" 286 | option <- getAChar 287 | when (option == 'y') $ hangmanGame wordsPath 288 | -------------------------------------------------------------------------------- /0003Sudoku.hs: -------------------------------------------------------------------------------- 1 | -- Sudoku solver by @ToJans 2 | -- 3 | -- Parses a Sudoku from a string and solves it 4 | -- Parsing happens by filtering out ['1'-'9'] and '.' 5 | 6 | {-# LANGUAGE OverloadedStrings #-} 7 | 8 | module Sudoko where 9 | 10 | import Data.Maybe(isNothing,fromMaybe) 11 | import Data.List(sortOn,find) 12 | 13 | newtype Value = Value Char deriving (Show,Eq) 14 | 15 | data Board = Board [[Maybe Value]] 16 | 17 | data Position = Position Int Int deriving Show 18 | 19 | data PotentialTurn = PotentialTurn Position [Value] deriving Show 20 | 21 | data Turn = Turn Position Value deriving Show 22 | 23 | data Range = Range [Position] deriving Show 24 | 25 | data StepOutcome = BoardSolved Board 26 | | BoardUnsolvable Board 27 | | PotentialBoards [Board] 28 | deriving Show 29 | 30 | allValidChars :: String 31 | allValidChars = ['1'..'9'] 32 | 33 | allValues :: [Value] 34 | allValues = map Value allValidChars 35 | 36 | charToMaybeValue :: Char -> Maybe Value 37 | charToMaybeValue c = if c `elem` allValidChars 38 | then Just $ Value c 39 | else Nothing 40 | 41 | maybeValueToChar :: Maybe Value -> Char 42 | maybeValueToChar (Just (Value v)) = v 43 | maybeValueToChar Nothing = '.' 44 | 45 | stringToBoard :: String -> Board 46 | stringToBoard x = if length filteredChars /= 9*9 47 | then error "Invalid board" 48 | else Board $ partition 9 filteredValues 49 | where allBoardChars = '.' : allValidChars 50 | filteredChars = filter (`elem` allBoardChars) x 51 | filteredValues = map charToMaybeValue filteredChars 52 | partition _ [] = [] 53 | partition n xs = take n xs : partition n (drop n xs) 54 | 55 | instance Show Board where 56 | show (Board b) = unlines $ "" : 57 | fullLine ++ 58 | map showLine [0..2] ++ 59 | fullLine ++ 60 | map showLine [3..5] ++ 61 | fullLine ++ 62 | map showLine [6..8] ++ 63 | fullLine 64 | where fullLine = [ "|-----------------------|" ] 65 | showLine y = foldl (\acc x -> acc ++ showEl x y) "" [0..8] ++ "|" 66 | showEl x y = prefix ++ (ch:" ") 67 | where prefix = if x `mod` 3 == 0 then "| " else "" 68 | mv = valueFromPosition (Board b) (Position x y) 69 | ch = maybeValueToChar mv 70 | 71 | rangesForPosition :: Position -> [Range] 72 | rangesForPosition (Position x y) = [rangeRow,rangeCol,range3By3] 73 | where rangeRow = Range $ map (`Position` y ) [0..8] 74 | rangeCol = Range $ map ( Position x ) [0..8] 75 | range3By3Left = (x `div` 3) * 3 76 | range3By3Top = (y `div` 3) * 3 77 | range3By3 = Range $ Position 78 | <$> [range3By3Left..range3By3Left+2] 79 | <*> [range3By3Top ..range3By3Top +2] 80 | 81 | valueFromPosition :: Board -> Position -> Maybe Value 82 | valueFromPosition (Board b) (Position x y) = b !! y !! x 83 | 84 | isValidValueForRange :: Board -> Range -> Value -> Bool 85 | isValidValueForRange b (Range positions) v = Just v `notElem` values 86 | where values = map (valueFromPosition b) positions 87 | 88 | isValidValueForPosition :: Board -> Position -> Value -> Bool 89 | isValidValueForPosition b p v = all (\r -> isValidValueForRange b r v) ranges 90 | where ranges = rangesForPosition p 91 | 92 | validValuesForPosition :: Board -> Position -> [Value] 93 | validValuesForPosition b p = filter (isValidValueForPosition b p) allValues 94 | 95 | positionsToGuess :: Board -> [Position] 96 | positionsToGuess b = filter (isNothing . valueFromPosition b ) allPositions 97 | where allPositions = Position <$> [0..8] <*> [0..8]; 98 | 99 | potentialTurn :: Board -> Position -> PotentialTurn 100 | potentialTurn b p = PotentialTurn p $ validValuesForPosition b p 101 | 102 | isPotentialTurnWithoutValues :: PotentialTurn -> Bool 103 | isPotentialTurnWithoutValues (PotentialTurn _ []) = True 104 | isPotentialTurnWithoutValues _ = False 105 | 106 | applyTurn :: Board -> Turn -> Board 107 | applyTurn (Board b) (Turn (Position x y) newVal) = 108 | Board $ replace y rowToReplace b 109 | where replace pos nv list = take pos list ++ nv : drop (pos+1) list 110 | rowToReplace = replace x (Just newVal) $ b !! y 111 | 112 | applyPotentialTurnsToBoard :: Board -> PotentialTurn -> [Board] 113 | applyPotentialTurnsToBoard b (PotentialTurn pos vals) = 114 | map getBoardForTurnVal vals 115 | where getBoardForTurnVal v = applyTurn b (Turn pos v) 116 | 117 | nextStep :: Board -> StepOutcome 118 | nextStep b 119 | | isBoardSolved = BoardSolved b 120 | | isNotSolvable = BoardUnsolvable b 121 | | otherwise = PotentialBoards potentialBoards 122 | where positionsToGuess' = positionsToGuess b 123 | isBoardSolved = null positionsToGuess' 124 | potentialTurns = map (potentialTurn b) positionsToGuess' 125 | potentialTurnLength (PotentialTurn _p v) = length v 126 | sortedPotentialTurns = sortOn potentialTurnLength potentialTurns 127 | -- we only need to walk the paths with the least possibilities 128 | potentialBoards = applyPotentialTurnsToBoard b $ head sortedPotentialTurns 129 | unsolvablePoints = filter isPotentialTurnWithoutValues potentialTurns 130 | isNotSolvable = not $ null unsolvablePoints 131 | 132 | isSolution :: StepOutcome -> Bool 133 | isSolution x = case x of 134 | BoardSolved _ -> True 135 | _ -> False 136 | 137 | isUnsolvable :: StepOutcome -> Bool 138 | isUnsolvable x = case x of 139 | BoardUnsolvable _ -> True 140 | _ -> False 141 | 142 | stepToBoards :: StepOutcome -> [Board] 143 | stepToBoards (PotentialBoards bs) = bs 144 | stepToBoards _ = [] 145 | 146 | solve :: Board -> StepOutcome 147 | solve b = case nextStep b of 148 | PotentialBoards bs -> solveMultiple bs 149 | BoardSolved bs -> BoardSolved bs 150 | BoardUnsolvable bs -> BoardUnsolvable bs 151 | where 152 | solveMultiple [] = BoardUnsolvable b 153 | solveMultiple bs = 154 | let ns = filter (not . isUnsolvable) $ map nextStep bs in 155 | fromMaybe 156 | (solveMultiple $ concatMap stepToBoards ns) 157 | (find isSolution ns) 158 | 159 | easyboard :: Board 160 | easyboard = stringToBoard 161 | "|-----------------------|\n\ 162 | \| 4 . 3 | 1 . . | 9 . 8 |\n\ 163 | \| . 2 9 | . . . | 4 5 . |\n\ 164 | \| 1 7 . | 8 4 9 | . . . |\n\ 165 | \|-----------------------|\n\ 166 | \| . 4 . | . 2 . | . . . |\n\ 167 | \| . 9 . | 4 . 7 | . 3 . |\n\ 168 | \| . . . | . 3 . | . 8 . |\n\ 169 | \|-----------------------|\n\ 170 | \| . . . | 5 9 8 | . 4 7 |\n\ 171 | \| . 5 7 | . . . | 8 6 . |\n\ 172 | \| 2 . 4 | . . 3 | 5 . 9 |\n\ 173 | \|-----------------------|\n" 174 | 175 | evilboard :: Board 176 | evilboard = stringToBoard 177 | "|-----------------------|\n\ 178 | \| . . . | . 4 5 | . . . |\n\ 179 | \| 8 . 6 | . 2 . | . 3 . |\n\ 180 | \| . . 2 | . . 8 | . . 6 |\n\ 181 | \|-----------------------|\n\ 182 | \| . 7 . | . . . | . 1 . |\n\ 183 | \| 9 . . | . 8 . | . . 3 |\n\ 184 | \| . 1 . | . . . | . 9 . |\n\ 185 | \|-----------------------|\n\ 186 | \| 3 . . | 9 . . | 5 . . |\n\ 187 | \| . 4 . | . 6 . | 3 . 7 |\n\ 188 | \| . . . | 8 3 . | . . . |\n\ 189 | \|-----------------------|\n" 190 | 191 | 192 | main :: IO () 193 | main = do 194 | putStrLn "Sudoku solver by @ToJans" 195 | putStrLn "Solving easy Sudoku" 196 | print easyboard 197 | print $ solve easyboard 198 | putStrLn "Solving evil sudoku" 199 | print evilboard 200 | print $ solve evilboard 201 | 202 | 203 | -- output: 204 | -- E:\Dev\haskell\learning>runhaskell "0003 Sudoku.hs" 205 | -- Sudoku solver by @ToJans 206 | -- 207 | -- |-----------------------| 208 | -- | 4 . 3 | 1 . . | 9 . 8 | 209 | -- | . 2 9 | . . . | 4 5 . | 210 | -- | 1 7 . | 8 4 9 | . . . | 211 | -- |-----------------------| 212 | -- | . 4 . | . 2 . | . . . | 213 | -- | . 9 . | 4 . 7 | . 3 . | 214 | -- | . . . | . 3 . | . 8 . | 215 | -- |-----------------------| 216 | -- | . . . | 5 9 8 | . 4 7 | 217 | -- | . 5 7 | . . . | 8 6 . | 218 | -- | 2 . 4 | . . 3 | 5 . 9 | 219 | -- |-----------------------| 220 | -- 221 | -- Finding solution 222 | -- BoardSolved 223 | -- |-----------------------| 224 | -- | 4 6 3 | 1 5 2 | 9 7 8 | 225 | -- | 8 2 9 | 3 7 6 | 4 5 1 | 226 | -- | 1 7 5 | 8 4 9 | 3 2 6 | 227 | -- |-----------------------| 228 | -- | 3 4 8 | 6 2 1 | 7 9 5 | 229 | -- | 5 9 6 | 4 8 7 | 1 3 2 | 230 | -- | 7 1 2 | 9 3 5 | 6 8 4 | 231 | -- |-----------------------| 232 | -- | 6 3 1 | 5 9 8 | 2 4 7 | 233 | -- | 9 5 7 | 2 1 4 | 8 6 3 | 234 | -- | 2 8 4 | 7 6 3 | 5 1 9 | 235 | -- |-----------------------| 236 | -- 237 | -- 238 | -- E:\Dev\haskell\learning> 239 | -------------------------------------------------------------------------------- /process.js: -------------------------------------------------------------------------------- 1 | "use strict"; 2 | 3 | function ImageRange(imgOrRange) { 4 | if (imgOrRange && imgOrRange.right && imgOrRange.bottom) { 5 | this.left = imgOrRange.left; 6 | this.right = imgOrRange.right; 7 | this.top = imgOrRange.top; 8 | this.bottom = imgOrRange.bottom; 9 | this.img = imgOrRange.img; 10 | } else if (imgOrRange && imgOrRange.width && imgOrRange.height) { 11 | this.left = 0; 12 | this.right = imgOrRange.width; 13 | this.top = 0; 14 | this.bottom = imgOrRange.height; 15 | this.img = imgOrRange; 16 | } else { 17 | this.left = 0; 18 | this.right = 0; 19 | this.top = 0; 20 | this.bottom = 0; 21 | this.img = {width:0,height:0,data:new Uint8ClampedArray(4)}; 22 | } 23 | this.width = this.right - this.left; 24 | this.height = this.bottom - this.top; 25 | this.area = this.width * this.height; 26 | this.center = {x:this.left+this.width/2,y:this.top+this.height/2}; 27 | } 28 | 29 | // folds over an image 30 | // takes an accFunc(acc,index,x,y,{r,g,b}) that returns the acc 31 | ImageRange.prototype.foldImgTopDownLeftRight = function(accFunc,acc,stepDown,stepRight) { 32 | var x,y,xi,yi,d=this.img.data,rgb; 33 | stepDown = stepDown || 1; 34 | stepRight = stepRight || 1; 35 | var sStepDown = stepDown * 4 * this.img.width; 36 | var sStepRight = stepRight * 4; 37 | yi = this.top*4*this.img.width + this.left*4; 38 | for (y = this.top;y<=this.bottom;y+=stepDown,yi+=sStepDown) { 39 | xi = yi; 40 | for (var x = this.left;x<=this.right;x+=stepRight,xi+=sStepRight) { 41 | rgb = {r:d[xi],g:d[xi+1],b:d[xi+2]}; 42 | acc = accFunc.call(this,acc,xi,x,y,rgb); 43 | } 44 | } 45 | return acc; 46 | }; 47 | 48 | // modify an image's colors 49 | // takes a modFunc(index,x,y,{r,g,b}) that returns an {r,g,b}; 50 | ImageRange.prototype.mapColor = function(modfunc,stepDown,stepRight) { 51 | var x,y,xi,yi,rgb,d,nd = new Uint8ClampedArray(this.img.data); 52 | d= this.img.data; 53 | stepDown = stepDown || 1; 54 | stepRight = stepRight || 1; 55 | var sStepDown = stepDown * 4 * this.img.width; 56 | var sStepRight = stepRight * 4; 57 | yi = this.top*4*this.img.width + this.left*4; 58 | for (y = this.top;y<=this.bottom;y+=stepDown,yi+=sStepDown) { 59 | xi = yi; 60 | for (var x = this.left;x<=this.right;x+=stepRight,xi+=sStepRight) { 61 | rgb = {r:d[xi],g:d[xi+1],b:d[xi+2]}; 62 | rgb = modfunc.call(this,xi,x,y,rgb); 63 | nd[xi] = rgb.r; 64 | nd[xi+1] = rgb.g; 65 | nd[xi+2] = rgb.b; 66 | } 67 | } 68 | return new ImageRange({ 69 | left: this.left, 70 | right: this.right, 71 | top: this.top, 72 | bottom: this.bottom, 73 | img: { 74 | data: nd, 75 | width: this.img.width, 76 | height: this.img.height 77 | } 78 | }); 79 | }; 80 | 81 | ImageRange.prototype.rangeFromColor=function(imgRange,r,g,b) { 82 | var initial = { left: bounds.right, 83 | right: bounds.left, 84 | top: bounds.bottom, 85 | bottom: bounds.top}; 86 | var d = img.data; 87 | var scanAcc = function(acc,i,x,y,rgb) { 88 | if (rgb.r!=r || rgb.g != g || rgb.b!= b) return acc; 89 | return { left: x < acc.left ? x : acc.left 90 | , right: x > acc.right ? x : acc.right 91 | , top: y < acc.top ? y : acc.top 92 | , bottom: y > acc.bottom ? y : acc.bottom 93 | }; 94 | }; 95 | var acc = this.foldImgTopDownLeftRight(scanAcc,initial); 96 | acc.img = this.img; 97 | return new ImageRange(acc); 98 | }; 99 | 100 | ImageRange.prototype.grayScale = function() { 101 | var v; 102 | return this.mapColor(function(i,x,y,rgb) { 103 | v = 0.2126*rgb.r + 0.7152*rgb.g + 0.0722*rgb.b; 104 | return {r:v,g:v,b:v} 105 | }); 106 | }; 107 | 108 | ImageRange.prototype.shrinkBound = function(size) { 109 | var nb = new ImageRange(this); 110 | nb.left += size; 111 | nb.right -= size; 112 | nb.top += size; 113 | nb.bottom -= size; 114 | return new ImageRange(nb); 115 | }; 116 | 117 | // folds over a square range of size n*2+1, only gets acc,x,y,rgb as inputs 118 | ImageRange.prototype.foldSquare = function(foldAcc,acc,x,y,size) { 119 | var xs,ys,yi,xi,rgb,downStep = this.img.width * 4,rightStep = 4; 120 | var d = this.img.data; 121 | yi = (y - size) * downStep + (x - size) * rightStep; 122 | for (ys = y-size;ys tresholdValue) { 163 | return {r:255,g:255,b:255}; 164 | } else { 165 | return {r:0,g:0,b:0}; 166 | } 167 | }); 168 | return nr; 169 | }; 170 | 171 | // floodfill at position, returns the bounded range 172 | ImageRange.prototype.floodFill = function(x,y,rgbCondition,rgb) { 173 | if (rgbCondition(rgb)) { 174 | throw "the fill color should not match the rgbCondition"; 175 | } 176 | var bnds = { 177 | left: this.right, 178 | right:this.left, 179 | top:this.bottom, 180 | bottom: this.top, 181 | }; 182 | var d = this.img.data,rgbv; 183 | var xs = [{x:x,y:y,i:x*4+y*this.img.width*4}],v; 184 | while (xs.length>0) { 185 | v = xs.pop(); 186 | if (v.x this.right || v.y < this.top || v.y > this.bottom) 187 | continue; 188 | rgbv = {r:d[v.i],g:d[v.i+1],b:d[v.i+2]}; 189 | if (!rgbCondition(rgbv)) continue; 190 | this.img.data[v.i ] = rgb.r; 191 | this.img.data[v.i+1] = rgb.g; 192 | this.img.data[v.i+2] = rgb.b; 193 | bnds = { 194 | left: v.x < bnds.left ? v.x : bnds.left, 195 | right: v.x > bnds.right ? v.x : bnds.right, 196 | top: v.y < bnds.top ? v.y : bnds.top, 197 | bottom: v.y > bnds.bottom ? v.y : bnds.bottom, 198 | } 199 | xs.push({x:v.x-1,y:v.y,i:v.i-4}); 200 | xs.push({x:v.x+1,y:v.y,i:v.i+4}); 201 | xs.push({x:v.x,y:v.y-1,i:v.i-4*this.img.width}); 202 | xs.push({x:v.x,y:v.y+1,i:v.i+4*this.img.width}); 203 | } 204 | bnds.img = this.img; 205 | return new ImageRange(bnds); 206 | } 207 | 208 | ImageRange.prototype.replaceColor=function(fromRGB,toRGB) { 209 | return this.mapColor(function(i,x,y,rgb) { 210 | if (fromRGB.r == rgb.r && fromRGB.g == rgb.g && fromRGB.b == rgb.b) { 211 | return toRGB; 212 | } else { 213 | return rgb; 214 | } 215 | }); 216 | } 217 | 218 | ImageRange.prototype.thickenColor = function(fromRGB,size) { 219 | size = size || 1; 220 | var d= this.img.data; 221 | var nd= new Uint8ClampedArray(d); 222 | var w = this.img.width 223 | for (var i=4*(w*size+size);i largestBlob.area && blobPredicate(ff)) { 274 | ff = ff.replaceColor(ImageRange.blobColors.current,ImageRange.blobColors.largest); 275 | largestBlob = ff; 276 | } else { 277 | ff = ff.replaceColor(ImageRange.blobColors.current,ImageRange.blobColors.other); 278 | } 279 | acc.img = ff.img; 280 | if (callback) callback(acc); 281 | return acc; 282 | } 283 | 284 | this.foldImgTopDownLeftRight(accFunc,largestBlob,stepDown,stepRight); 285 | 286 | return largestBlob; 287 | } 288 | 289 | // find lines in image; returs lines array 290 | // only works on pixels colored in matchColor 291 | // requires the lines to cover at least minPixelCount 292 | ImageRange.prototype.houghLines = function(matchColor,minPixelCount,minAngleDiff,minDistanceDiff,callback) { 293 | minAngleDiff = minAngleDiff || 5; 294 | minDistanceDiff = minDistanceDiff || 5; 295 | var maxAngles = 180; 296 | var sines = []; 297 | var da = Math.PI/maxAngles; 298 | var maxSize = Math.sqrt( this.width * this.width + this.height * this.height); 299 | // cache sines & cosines for performance reasons 300 | for (var i=0,a=0;iself.left && xself.top && y < self.bottom) { 351 | var sy= Math.round(y); 352 | var sx= Math.round(x); 353 | var si = sy*img.width+sx; 354 | si*=4; 355 | if (insideLen > 0 ) { 356 | if (isMatch(si)) { 357 | insideLen++; 358 | current.x2 = sx;current.y2 = sy; 359 | } else { 360 | if (insideLen>minLineSize) { 361 | result.cnt += insideLen; 362 | result.lines.push(current); 363 | } 364 | insideLen = 0; 365 | } 366 | } else if (insideLen == 0 && isMatch(si)) { 367 | insideLen = 1; 368 | current = {x:sx,y:sy} 369 | } 370 | } 371 | } 372 | return result; 373 | } 374 | 375 | var selected = []; 376 | 377 | // check every pixel in normal space, find the ones 378 | // with the largest amounts of pixels on a line, 379 | // locality for theta = minAngleDiff 380 | // locality for rho = minDistanceDiff 381 | for (var theta=0;theta minAngleDiff || dTheta > minDistanceDiff) continue; 401 | // a close record found, so we either replace it or do nothing 402 | shouldPush = false; 403 | // if the current count of pixels is larger than the previous, 404 | // replace the item in the list 405 | if ( cnt > x.cnt) { 406 | selected[i] = res; 407 | break; 408 | } 409 | } 410 | if (shouldPush) selected.push(res); 411 | } 412 | }; 413 | 414 | var min = function() { 415 | return new Array(arguments).reduce(function(acc,x){return xacc?x:acc;}); 419 | } 420 | 421 | // we are only interested in the endpoints of the lines 422 | var lines = selected.map(function(r) { 423 | return r.lines.reduce(function(acc,l){ 424 | return { 425 | x: min(acc.x,l.x,l.x2), 426 | y: min(acc.y,l.y,l.y2), 427 | x2: max(acc.x,l.x,l.x2), 428 | y2: max(acc.y,l.y,l.y2) 429 | }; 430 | }); 431 | }); 432 | 433 | return lines; 434 | 435 | } 436 | 437 | var evts = {}; 438 | 439 | evts.imageUpdated = function (imgRange) { 440 | self.postMessage({msgType:'imageUpdated',data:imgRange.img}); 441 | } 442 | 443 | evts.lines = function(lines){ 444 | self.postMessage({msgType:'lines',data:lines}); 445 | } 446 | 447 | evts.error = function(msg) { 448 | self.postMessage({msgType:'error',data:msg}); 449 | } 450 | 451 | evts.info = function(msg) { 452 | self.postMessage({msgType:'info',data:msg}); 453 | } 454 | 455 | var cmds = {}; 456 | 457 | function isValidSudokuBlob (imageRange) { 458 | var dx = imageRange.img.width - imageRange.img.height; 459 | var dy = imageRange.img.height - imageRange.img.width; 460 | dx = dx > 0 ? dx/2 : 0; 461 | dy = dy > 0 ? dy/2 : 0; 462 | return (imageRange.width+dx*2) > imageRange.img.width /3 && 463 | (imageRange.height+dy*2) > imageRange.img.height / 3 && 464 | imageRange.center.x + dx > imageRange.img.width/3 && 465 | imageRange.center.y + dy > imageRange.img.height/3 && 466 | imageRange.center.x - dx < imageRange.img.width*2/3 && 467 | imageRange.center.y - dy < imageRange.img.height*2/3 && 468 | imageRange.left > 10 && 469 | imageRange.right < imageRange.img.width - 10 && 470 | imageRange.top > 10 && 471 | imageRange.bottom < imageRange.img.height - 10; 472 | } 473 | 474 | cmds.processImage = function (e) { 475 | var img = e.data; 476 | var result = new ImageRange(img) 477 | evts.info('processing image'); 478 | evts.imageUpdated(result); 479 | evts.info('converting to grayscale'); 480 | result = result.grayScale(); 481 | evts.imageUpdated(result); 482 | evts.info('converting to black and white'); 483 | result = result.adaptiveTreshold(10,0.9); 484 | evts.imageUpdated(result); 485 | evts.info('locating sudoku'); 486 | var minsize = (img.width < img.height ? img.width:img.height)/2; 487 | result = result.largestBlob(minsize, isValidSudokuBlob,evts.imageUpdated); 488 | evts.imageUpdated(result); 489 | if (result.area == 0) { 490 | evts.info('unable to locate sudoku'); 491 | return; 492 | } 493 | evts.info('thickening sudoku edges'); 494 | result = result.thickenColor(ImageRange.blobColors.largest,6); 495 | evts.imageUpdated(result); 496 | evts.info('finding lines'); 497 | // result = result.findRectangleCorners(); 498 | var minLength = result.width