Personal tools

Haskell Quiz/The Solitaire Cipher/Solution Paul

From HaskellWiki

< Haskell Quiz | The Solitaire Cipher(Difference between revisions)
Jump to: navigation, search
(sharpen cat)
m
 
Line 11: Line 11:
   
 
to_number :: Char -> Int
 
to_number :: Char -> Int
to_number c = (fromEnum c) - (fromEnum 'A') + 1
+
to_number c = fromEnum c - fromEnum 'A' + 1
   
 
from_number :: Int -> Char
 
from_number :: Int -> Char
from_number n = (toEnum (n - 1 + fromEnum 'A'))
+
from_number n = toEnum (n - 1 + fromEnum 'A')
   
 
to_numbers :: String -> [Int]
 
to_numbers :: String -> [Int]
to_numbers s = map to_number s
+
to_numbers = map to_number
   
 
cleanse :: String -> String
 
cleanse :: String -> String
cleanse c = (map toUpper) ((filter isAlpha) c)
+
cleanse = map toUpper . filter isAlpha
   
 
pad :: Int -> Char -> String -> String
 
pad :: Int -> Char -> String -> String
pad n c s | length s < n = s ++ (replicate (n-length s) c)
+
pad n c s | length s < n = s ++ replicate (n-length s) c
pad n c s = s
+
pad n c s | otherwise = s
   
 
maybe_split :: String -> Maybe(String,String)
 
maybe_split :: String -> Maybe(String,String)
 
maybe_split [] = Nothing
 
maybe_split [] = Nothing
 
maybe_split s | w == "" = Just (pad 5 'X' s,w)
 
maybe_split s | w == "" = Just (pad 5 'X' s,w)
| True = Just (take 5 s, w)
+
| otherwise = Just (take 5 s, w)
 
where w = drop 5 s
 
where w = drop 5 s
   
 
quintets :: String -> [String]
 
quintets :: String -> [String]
quintets s = (unfoldr maybe_split) s
+
quintets = unfoldr maybe_split
   
 
data Suit = Clubs | Diamonds | Hearts | Spades | A | B
 
data Suit = Clubs | Diamonds | Hearts | Spades | A | B
Line 39: Line 39:
   
 
show_suit :: Suit -> String
 
show_suit :: Suit -> String
show_suit s = (take 1) (show s)
+
show_suit = head . show
   
 
data Face = Ace | Two | Three | Four | Five | Six | Seven
 
data Face = Ace | Two | Three | Four | Five | Six | Seven
Line 46: Line 46:
 
 
 
show_face :: Face -> String
 
show_face :: Face -> String
show_face f = [head (drop (fromEnum f) "A23456789TJQK$")]
+
show_face f = ["A23456789TJQK$" !! fromEnum f]
   
data Card = Cd Suit Face
+
data Card = Cd {suit :: Suit, face :: Face}
 
deriving Eq
 
deriving Eq
 
suit :: Card -> Suit
 
suit (Cd s _) = s
 
 
face :: Card -> Face
 
face (Cd _ f) = f
 
   
 
instance Enum Card where
 
instance Enum Card where
toEnum 53 = (Cd B Joker)
+
toEnum 53 = Cd B Joker
toEnum 52 = (Cd A Joker)
+
toEnum 52 = Cd A Joker
toEnum n = let d = n `divMod` 13
+
toEnum n = let (q,r) = n `divMod` 13
in Cd (toEnum (fst d)) (toEnum (snd d))
+
in Cd (toEnum q) (toEnum r)
 
fromEnum (Cd B Joker) = 53
 
fromEnum (Cd B Joker) = 53
 
fromEnum (Cd A Joker) = 52
 
fromEnum (Cd A Joker) = 52
Line 67: Line 61:
   
 
instance Show Card where
 
instance Show Card where
show c = (show_face (face c)) ++ (show_suit (suit c))
+
show c = show_face (face c) ++ show_suit (suit c)
   
 
value :: Card -> Int
 
value :: Card -> Int
 
value (Cd B Joker) = 53
 
value (Cd B Joker) = 53
 
value c = fromEnum c + 1
 
value c = fromEnum c + 1
 
drop_tail :: [a] -> [a]
 
drop_tail l = reverse (drop 1 (reverse l))
 
   
 
split_on_elem :: Eq a => a -> [a] -> ([a],[a])
 
split_on_elem :: Eq a => a -> [a] -> ([a],[a])
split_on_elem x l | x == head l = ([],drop 1 l)
+
split_on_elem x l | x == head l = ([],tail l)
split_on_elem x l | x == head (reverse l) = (drop_tail l, [])
+
split_on_elem x l | x == last l = (init l, [])
split_on_elem x l | elemIndex x l == Nothing = error "Can't split a list on an element that isn't present."
+
split_on_elem x l | otherwise = case elemIndex x l of
split_on_elem x l = let y = fromJust(elemIndex x l)
+
Nothing -> error "Can't split a list on an element that isn't present."
in (take y l, drop (y+1) l)
+
Just y -> (take y l, drop (y+1) l)
   
 
swap_down :: Card -> [Card] -> [Card]
 
swap_down :: Card -> [Card] -> [Card]
swap_down x deck | (fst halves) == [] = (head (snd halves)):(x:(drop 1 (snd halves)))
+
swap_down x deck | null xs = head ys:x:tail ys
| (snd halves) == [] = (head (fst halves)):x:(drop 1 (fst halves))
+
| null ys = head xs:x:tail xs
| True = (fst halves) ++ ((head (snd halves)):x:(drop 1 (snd halves)))
+
| otherwise = xs ++ (head ys:x:tail ys)
where halves = split_on_elem x deck
+
where (xs,ys) = split_on_elem x deck
 
 
 
move_a :: [Card] -> [Card]
 
move_a :: [Card] -> [Card]
Line 100: Line 91:
 
 
 
triple_cut :: Card -> Card -> [Card] -> [Card]
 
triple_cut :: Card -> Card -> [Card] -> [Card]
triple_cut x y deck | slot_x < slot_y = (snd (split_y)) ++ (x:(from_m_to_n slot_x slot_y deck)) ++ (y:(fst split_x))
+
triple_cut x y deck | slot_x < slot_y = y2 ++ (x:(from_m_to_n slot_x slot_y deck)) ++ (y:x1)
| slot_x > slot_y = (snd (split_x)) ++ (y:(from_m_to_n slot_y slot_x deck)) ++ (x:(fst split_y))
+
| slot_x > slot_y = x2 ++ (y:(from_m_to_n slot_y slot_x deck)) ++ (x:y1)
where slot_x = fromJust(elemIndex x deck)
+
where Just slot_x = elemIndex x deck
slot_y = fromJust(elemIndex y deck)
+
Just slot_y = elemIndex y deck
split_x = split_on_elem x deck
+
(x1,x2) = split_on_elem x deck
split_y = split_on_elem y deck
+
(y1,y2) = split_on_elem y deck
 
 
 
triple_cut_a_b :: [Card] -> [Card]
 
triple_cut_a_b :: [Card] -> [Card]
Line 111: Line 102:
   
 
count_cut :: [Card] -> [Card]
 
count_cut :: [Card] -> [Card]
count_cut deck = (drop_tail (drop val deck)) ++ (take val deck) ++ [bottom_card]
+
count_cut deck = drop (val-1) deck ++ take val deck ++ [bottom_card]
where bottom_card = head (reverse deck)
+
where bottom_card = last deck
 
val = value (bottom_card)
 
val = value (bottom_card)
   
 
evaluate :: [Card] -> Int
 
evaluate :: [Card] -> Int
evaluate deck = value (head (drop (value(head(deck))) deck))
+
evaluate deck = value (deck !! value (head deck))
   
 
compute :: [Card] -> (Int,[Card])
 
compute :: [Card] -> (Int,[Card])
compute deck | val == 53 = compute (x)
+
compute deck | val == 53 = compute x
| True = ((val `mod` 26), x)
+
| otherwise = (val `mod` 26, x)
where x = count_cut ( triple_cut_a_b ( move_b ( move_a ( deck ))))
+
where x = count_cut $ triple_cut_a_b $ move_b $ move_a $ deck
 
val = evaluate x
 
val = evaluate x
   
Line 129: Line 120:
 
encode_ :: String -> [Card] -> String
 
encode_ :: String -> [Card] -> String
 
encode_ [] _ = []
 
encode_ [] _ = []
encode_ (s:ss) deck = let c = compute(deck)
+
encode_ (s:ss) deck = let (a,b) = compute deck
in (from_number(wrap_zero ((fst c + (to_number s)) `mod` 26))):(encode_ ss (snd c))
+
in from_number(wrap_zero ((a + to_number s) `mod` 26)):encode_ ss b
   
 
decode :: String -> String
 
decode :: String -> String
Line 137: Line 128:
 
decode_ :: String -> [Card] -> String
 
decode_ :: String -> [Card] -> String
 
decode_ [] _ = []
 
decode_ [] _ = []
decode_ (s:ss) deck = let c = compute(deck)
+
decode_ (s:ss) deck = let (a,b) = compute deck
in (from_number(wrap_zero ((26 + (to_number s) - fst c) `mod` 26))):(decode_ ss (snd c))
+
in from_number(wrap_zero ((26 + to_number s - a) `mod` 26)):decode_ ss b
   
 
wrap_zero :: Int -> Int
 
wrap_zero :: Int -> Int

Latest revision as of 19:33, 21 February 2010


-- Solution to Ruby Quiz problem #1
-- Paul Brown ([email protected])
-- http://mult.ifario.us/
 
import Char
import List
import Maybe
 
to_number :: Char  -> Int
to_number c = fromEnum c - fromEnum 'A' + 1
 
from_number :: Int -> Char
from_number n = toEnum (n - 1 + fromEnum 'A')
 
to_numbers :: String -> [Int]
to_numbers = map to_number
 
cleanse :: String -> String
cleanse = map toUpper . filter isAlpha
 
pad :: Int -> Char -> String -> String
pad n c s | length s < n = s ++ replicate (n-length s) c
pad n c s | otherwise = s
 
maybe_split :: String -> Maybe(String,String)
maybe_split [] = Nothing
maybe_split s | w == "" = Just (pad 5 'X' s,w)
              | otherwise = Just (take 5 s, w)
              where w = drop 5 s
 
quintets :: String -> [String]
quintets = unfoldr maybe_split
 
data Suit = Clubs | Diamonds | Hearts | Spades | A | B
            deriving (Enum, Show, Bounded, Eq)
 
show_suit :: Suit -> String
show_suit = head . show
 
data Face = Ace | Two | Three | Four | Five | Six | Seven 
          | Eight | Nine | Ten | Jack | Queen | King | Joker
            deriving (Enum, Show, Bounded, Eq)
 
show_face :: Face -> String
show_face f = ["A23456789TJQK$" !! fromEnum f] 
 
data Card = Cd {suit :: Suit, face :: Face}
          deriving Eq
 
instance Enum Card where
    toEnum 53 = Cd B Joker
    toEnum 52 = Cd A Joker
    toEnum n = let (q,r) = n `divMod` 13
               in Cd (toEnum q) (toEnum r)
    fromEnum (Cd B Joker) = 53
    fromEnum (Cd A Joker) = 52
    fromEnum c = 13* fromEnum(suit c) + fromEnum(face c)
 
instance Show Card where
    show c = show_face (face c) ++ show_suit (suit c)
 
value :: Card -> Int
value (Cd B Joker) = 53
value c = fromEnum c + 1
 
split_on_elem :: Eq a => a -> [a] -> ([a],[a])
split_on_elem x l | x == head l = ([],tail l)
split_on_elem x l | x == last l = (init l, [])
split_on_elem x l | otherwise = case elemIndex x l of
                                Nothing -> error "Can't split a list on an element that isn't present."
                                Just y  -> (take y l, drop (y+1) l)
 
swap_down :: Card -> [Card] -> [Card]
swap_down x deck | null xs = head ys:x:tail ys
                 | null ys = head xs:x:tail xs
                 | otherwise = xs ++ (head ys:x:tail ys)
    where (xs,ys) = split_on_elem x deck
 
move_a :: [Card] -> [Card]
move_a deck = swap_down (Cd A Joker) deck
 
move_b :: [Card] -> [Card]
move_b deck = swap_down (Cd B Joker) (swap_down (Cd B Joker) deck)
 
from_m_to_n :: Int -> Int -> [a] -> [a]
from_m_to_n m n l | m < n = take (n-m-1) (drop (m+1) l)
                  | n < m = take (m-n-1) (drop (n+1) l)
 
triple_cut :: Card -> Card -> [Card] -> [Card]
triple_cut x y deck | slot_x < slot_y = y2 ++ (x:(from_m_to_n slot_x slot_y deck)) ++ (y:x1)
                    | slot_x > slot_y = x2 ++ (y:(from_m_to_n slot_y slot_x deck)) ++ (x:y1)
                    where Just slot_x = elemIndex x deck
                          Just slot_y = elemIndex y deck
                          (x1,x2) = split_on_elem x deck
                          (y1,y2) = split_on_elem y deck
 
triple_cut_a_b :: [Card] -> [Card]
triple_cut_a_b deck = triple_cut (Cd A Joker) (Cd B Joker) deck
 
count_cut :: [Card] -> [Card]
count_cut deck = drop (val-1) deck ++ take val deck ++ [bottom_card]
               where bottom_card = last deck
                     val = value (bottom_card)
 
evaluate :: [Card] -> Int
evaluate deck = value (deck !! value (head deck))
 
compute :: [Card] -> (Int,[Card])
compute deck | val == 53 = compute x
             | otherwise = (val `mod` 26, x)
             where x = count_cut $ triple_cut_a_b $ move_b $ move_a $ deck
                   val = evaluate x
 
encode :: String -> String
encode s = encode_ (concat (quintets (cleanse s))) [(Cd Clubs Ace) .. (Cd B Joker)]
 
encode_ :: String -> [Card] -> String
encode_ [] _ = []
encode_ (s:ss) deck = let (a,b) = compute deck
                        in from_number(wrap_zero ((a + to_number s) `mod` 26)):encode_ ss b
 
decode :: String -> String
decode s = decode_ s [(Cd Clubs Ace) .. (Cd B Joker)]
 
decode_ :: String -> [Card] -> String
decode_ [] _ = []
decode_ (s:ss) deck = let (a,b) = compute deck
                      in from_number(wrap_zero ((26 + to_number s - a) `mod` 26)):decode_ ss b
 
wrap_zero :: Int -> Int
wrap_zero 0 = 26
wrap_zero x = x