siteswap.hs

import Control.Arrow ((&&&)) 
import Data.List (delete, elemIndices, nub, permutations, sort) 
import Data.Random.Distribution.Normal 
import System.Random 
 
-- FAUX LIBRARIES -- 
 
intToDigit35 :: Int -> Char 
intToDigit35 i 
 | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i) 
 | i >= 10 && i <= 35 = toEnum (fromEnum 'a' + i - 10) 
 | otherwise = error "Char.intToDigit35: not a digit" 
 
-- FOOOOOH -- 
 
type AsyncCard = [Int] -- must be descending and positive 
type AsyncSiteswap = [[Int]] 
type Steps = Int 
type Length = Int 
type Height = Int 
type Index = Int 
data SyncCard = SyncCard { left :: AsyncCard 
 , right :: AsyncCard 
 } deriving (Show) 
data InitialSide = LHS | RHS deriving (Enum) 
 
-- fragment of a card (must be descending and positive) 
-- current height 
-- returns height when card has been evaluated 
dropHeight :: AsyncCard -> Height -> Height 
dropHeight _ 0 = 0 -- never return negatives for convenience 
dropHeight [] height = height 
dropHeight (toss:tosses) height = 
 dropHeight tosses $ if toss >= height then height - 1 else height 
 
-- Cards: the deck being looked at 
-- Steps: how many steps have been taken so far 
-- Height: remaining height on the arrow being looked at 
-- Index: Index in the deck that the arrow is at 
-- Returns how many steps the arrow took before landing. 
handleOneArrow :: [AsyncCard] -> Steps -> Index -> Height -> Int 
handleOneArrow [] _ _ _ = 0 
handleOneArrow _ steps _ 0 = steps 
handleOneArrow cards steps index accum = 
 handleOneArrow 
 cards 
 (steps + 1) 
 (index + 1) 
 (dropHeight card accum) 
 where card = cards !! mod index (length cards) 
handleLeftArrow :: [SyncCard] -> InitialSide -> Steps -> Height -> Index -> Int 
handleLeftArrow [] _ _ _ _ = 0 -- degenerate case but technically correct? 
handleLeftArrow _ LHS steps 0 _ = -1 * steps -- this landed RHS so it's crossing
handleLeftArrow _ RHS steps 0 _ = steps -- this landed LHS so it's noncrossing
handleLeftArrow cards initside steps accum index = 
 handleRightArrow 
 cards 
 initside 
 (steps + 2) 
 (dropHeight card accum) 
 index 
 where card = left $ cards !! mod index (length cards) 
 
handleRightArrow :: [SyncCard] -> InitialSide -> Steps -> Height -> Index -> Int 
handleRightArrow [] _ _ _ _ = 0 -- degenerate case but technically correct? 
handleRightArrow _ LHS steps 0 _ = steps -- this landed RHS so it's noncrossing
handleRightArrow _ RHS steps 0 _ = -1 * steps -- this landed LHS so it's crossing
handleRightArrow cards initside steps accum index = 
 handleLeftArrow 
 cards 
 initside 
 steps 
 (dropHeight card accum) 
 (index + 1) 
 where card = right $ cards !! mod index (length cards) 
 
 
convertOneMultiplex :: [AsyncCard] -> AsyncSiteswap 
convertOneMultiplex cards = 
 map (\(card,index) -> map (handleOneArrow cards 0 index) card) $ zip cards [1..]
 
convertOneSyncMultiplex :: [SyncCard] -> [([Int], [Int])] 
convertOneSyncMultiplex xs = 
 map (\(synccard, index) -> (,) 
 (map (\h -> handleRightArrow xs LHS 0 h index) (left synccard)) 
 (map (\h -> handleLeftArrow xs RHS 0 h (index + 1)) (right synccard)) 
 ) 
 $ zip xs [0..] 
 
printVal :: Int -> String 
printVal x 
 | x >= 0 = [intToDigit35 x] 
 | otherwise = intToDigit35 (-x) : "x" 
 
asyncToString :: [AsyncCard] -> String 
asyncToString [] = "" 
asyncToString ([x]:xs) = printVal x ++ asyncToString xs 
asyncToString (x:xs) = "[" ++ concatMap printVal x ++ "]" ++ asyncToString xs 
 
syncToString :: [([Int], [Int])] -> String 
syncToString [] = "" 
syncToString ((l,r):xs) = "(" ++ asyncToString [l] ++ "," ++ asyncToString [r] 
 ++ ")" ++ syncToString xs 
 
-- list of random integers of length L between [0,k] 
-- list of random integers of length L between [0, 2^k] 
-- list of random integers of length L between [0, (k+1)*k] 
-- list of random integers of length L between [0, 3^k] 
-- list of random integers of length L between [0, n] 
 
listRandomUnder :: (Int -> Int) -> (Length, Length) -> IO [Int] 
listRandomUnder f (minLen, maxLen) = do 
 len <- randomRIO (minLen, maxLen) 
 gen <- getStdGen 
 minHeight <- randomRIO (0, 1) -- (3, div 35 len) 
 let maxHeight = f (div 35 len) 
 return $ take len $ randomRs (minHeight, maxHeight) gen 
 
--randomVanillaSiteswap :: IO AsyncSiteswap 
--randomVanillaSiteswap = do 
-- let minLength = 2 :: Length 
-- let maxLength = 10 :: Length 
-- xs <- listRandomUnder id (minLength, maxLength) :: IO [Int] 
-- return $ convertOneMultiplex $ map (: []) xs 
 
intToBaseList :: Int -> Int -> [Int] 
intToBaseList 0 b = [] 
intToBaseList x b = (x `mod` b) : intToBaseList (x `div` b) b 
 
intToAsyncCard :: Int -> AsyncCard 
intToAsyncCard 0 = [0] 
intToAsyncCard n = map (+1) $ reverse $ elemIndices 1 $ intToBaseList n 2 
 
genRandomMultiplexCards :: IO [AsyncCard] 
genRandomMultiplexCards = do 
 let minLength = 2 :: Length 
 let maxLength = 10 :: Length 
 xs <- listRandomUnder (\x -> 2^x) (minLength, maxLength) :: IO [Int] 
 return $ convertOneMultiplex $ map intToAsyncCard xs 
 
--pareDown :: [Int] -> IO [Int] 
--pareDown xs = do 
-- len <- randomRIO (0, length xs) 
-- if (length xs <= 3) then 
-- return xs 
-- else 
 
 
 
-- intToSyncMultiplexCard :: Int -> SyncCard 
-- intToSyncMultiplexCard n = intToBaseList n 3 
 
main = do 
 --rVS <- randomVanillaSiteswap 
 --putStrLn $ asyncToString rVS 
 rMCs <- genRandomMultiplexCards :: IO [AsyncCard] 
 putStrLn $ asyncToString rMCs