Stuff I made in Haskell

josephus.hs

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))

politician.hs

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

roman.hs

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"

sieve.hs

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