Skip to content
{{ message }}

Instantly share code, notes, and snippets.

# flq/josephus.hs

Last active Aug 16, 2018
Stuff I made in Haskell
 module Josephus where import Data.List -- own, atrocious solution to josephus problem lastSurvivor :: Int -> Int lastSurvivor 1 = 1 lastSurvivor noOfPeople = fst . last \$ unfoldr theSurvivors (1,(1,[])) where theSurvivors (person, (count, theKilled)) | length theKilled == noOfPeople - 1 = Just (countOn, breakCondition) | person == 0 = Nothing | count == 3 = Just (current, nextSuicide) | otherwise = Just (current, countOn) where breakCondition = (0,(0,[])) current = (person,(count,theKilled)) nextPerson = getNextPerson noOfPeople theKilled person nextSuicide = (nextPerson, (1, theKilled++[person])) countOn = (nextPerson, (count + 1, theKilled)) getNextPerson :: Int -> [Int] -> Int -> Int getNextPerson noOfPeople theKilled person = thePeople !! next where next = case (findIndex (\p -> p == person) thePeople) of Nothing -> error "catastrophic solution space exhaustion exception" Just n -> n + 1 thePeople = cycle ([1..noOfPeople] \\ theKilled) -- Taken, then fixed and symbol renaming from -- http://en.wikipedia.org/wiki/Josephus_problem#The_general_case josephus noOfPeople k = josephus' [1..noOfPeople] k where josephus' people k | length people == 1 = head people | otherwise = josephus' (killnext k people) k where killnext k people = take (length people - 1) (drop k (cycle people))
 module Politics where import Data.List type Q = String type S = String data Statement = Statement Q S data Fallacy = AppealToProbability Statement | ArgumentFromFallacy Statement | AppealToAuthority Statement | ArgumentFromSilence Statement | AdHominem Statement | AppealToFear Statement class Politician a where knowledge :: a -> [Statement] lieify :: a -> Maybe Statement -> Maybe Fallacy ask :: a -> Q -> Maybe Fallacy ask a q = lieify a answer where knows = knowledge a answer = find search knows search (Statement qstn _) = qstn == q
 module Roman where import Data.List atoms = [("M",1000),("CM",900),("D",500),("CD",400),("C",100),("XC",90), ("L",50),("XL",40),("X",10),("IX",9),("V",5),("IV",4),("I",1)] data Roman = R String | RN Int instance Show Roman where show a = show \$ romanToString a instance Eq Roman where (==) a b = romanToInt a == romanToInt b instance Num Roman where (+) x y = RN (romanToInt x + romanToInt y) (-) x y = RN (romanToInt x - romanToInt y) (*) x y = RN (romanToInt x * romanToInt y) abs = RN . abs . romanToInt fromInteger = RN . fromIntegral signum = RN . signum . romanToInt romanStringToInt :: String -> Int romanStringToInt input = twoLetterSum + (singleLetter reduced) where twoLetterSum = sum \$ map snd matchingTwoLetters reduced = foldl (\\) input \$ map fst matchingTwoLetters matchingTwoLetters = [ (lt,num) |(lt,num) <- atoms, length lt == 2, isInfixOf lt input] singleLetter [] = 0 singleLetter (l:ls) = numberFor [l] + singleLetter ls where numberFor l = snd \$ findOrFail (finder l) atoms finder l = (\x -> fst x == l) intToRomanString :: Int -> String intToRomanString 0 = "" intToRomanString a = case (x) of Just (letter,number) -> letter ++ intToRomanString (a - number) Nothing -> error "romans did not have negative numbers" where x = head' [(l,num) | (l,num) <- atoms, a - num >= 0] romanToString :: Roman -> String romanToString x = case (x) of R x -> x RN x -> intToRomanString x romanToInt :: Roman -> Int romanToInt x = case (x) of RN x -> x R x -> romanStringToInt x head' [] = Nothing head' (x:xs) = Just x findOrFail x y = wrap \$ find x y where wrap x = case (x) of Just that -> that Nothing -> error "Could not find any element that satisfies condition"
 module Sieve where sieve :: Int -> [Int] sieve n = runSieve [2..n] where runSieve (n:ns) | n > limit = n : ns | otherwise = n : runSieve [x | x <- ns, x `mod` n /= 0] limit = nearestSquare n nearestSquare = floor . sqrt . fromIntegral
to join this conversation on GitHub. Already have an account? Sign in to comment