Skip to content

Instantly share code, notes, and snippets.

@flq

flq/josephus.hs

Last active Aug 16, 2018
Embed
What would you like to do?
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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment