Skip to content

Instantly share code, notes, and snippets.

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