diff options
Diffstat (limited to 'semestr-3/pf/lista10/l10.hs')
| -rw-r--r-- | semestr-3/pf/lista10/l10.hs | 233 |
1 files changed, 233 insertions, 0 deletions
diff --git a/semestr-3/pf/lista10/l10.hs b/semestr-3/pf/lista10/l10.hs new file mode 100644 index 0000000..647fa30 --- /dev/null +++ b/semestr-3/pf/lista10/l10.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} + + +import Data.Char (toLower) +import System.IO (IOMode(ReadMode, ReadWriteMode), openFile, stdout, hIsEOF, hGetChar, hPutChar, Handle, isEOF, BufferMode(NoBuffering), hSetBuffering, stdin ) +import Control.Monad (when) +import Control.Monad.State +import Control.Concurrent (threadDelay) +import Control.Monad.Trans.Maybe +import System.Environment (getArgs) + +-- Zadanie 1 + +int :: (String -> a) -> String -> Integer -> a +int f s n = f (s ++ show n) + +str :: (String -> a) -> String -> String -> a +str f s1 s2 = f (s1 ++ s2) + +lit :: String -> (String -> a) -> String -> a +lit s f s2 = f (s2 ++ s) + +(^^) :: (b -> c) -> (a -> b) -> a -> c +(^^) f g x = f (g x) + +sprintf :: ((a -> a) -> [Char] -> t) -> t +sprintf f = f id "" + +-- Zadanie 2 + +data Format a b where + Lit :: String -> Format a a + Int :: Format a (Int -> a) + Str :: Format a (String -> a) + (:^:) :: Format c b -> Format a c -> Format a b + + +ksprintf :: Format a b -> (String -> a) -> String -> b +ksprintf (Lit s1) cont = \s2 -> cont (s2 ++ s1) +ksprintf Int cont = \s n -> cont (s ++ show n) +ksprintf Str cont = \s1 s2 -> cont (s1 ++ s2) +ksprintf (a :^: b) cont = ksprintf a (ksprintf b cont) + +kprintf :: Format a b -> (IO () -> a) -> b +kprintf (Lit s1) cont = cont (putStr s1) +kprintf Int cont = \n -> cont (putStr (show n)) +kprintf Str cont = \s -> cont (putStr s) +kprintf (a :^: b) cont = kprintf a (\s1 -> kprintf b (\s2 -> cont (s1 >> s2))) + +printf :: Format (IO ()) b -> b +printf frmt = kprintf frmt id + +sprintf2 :: Format String b -> b +sprintf2 frmt = ksprintf frmt id "" + + +-- Zadanie 3 + +echoLower :: IO () +echoLower = do x <- getChar + putChar (toLower x) + echoLower + +-- Zadanie 4 + +data StreamTrans i o a + = Return a + | ReadS (Maybe i -> StreamTrans i o a) + | WriteS o (StreamTrans i o a) + +myToLower :: StreamTrans Char Char () +myToLower = ReadS f where + f (Just i) = WriteS (toLower i) myToLower + f Nothing = Return () + +runStreams :: StreamTrans Char Char a -> IO a +runStreams (Return a) = return a +runStreams (ReadS f) = do + eof <- isEOF + if eof + then runStreams (f Nothing) + else do + c <- getChar + runStreams (f (Just c)) +runStreams (WriteS out str) = do + putChar out + runStreams str + +-- Zadanie 5 + +listTrans :: StreamTrans i o a -> [i] -> ([o], a) +listTrans (Return a) xs = ([], a) +listTrans (ReadS f) [] = listTrans (f Nothing) [] +listTrans (ReadS f) (x:xs) = listTrans (f (Just x)) xs +listTrans (WriteS out str) xs = + let (ys, a) = listTrans str xs + in (out : ys, a) + +-- Zadanie 6 + +runCycle :: StreamTrans a a b -> b +runCycle (Return b) = b +runCycle (ReadS f) = runCycle (f Nothing) +runCycle (WriteS out (ReadS f)) = runCycle (f (Just out)) +runCycle (WriteS _ str) = runCycle str + +-- Zadanie 7 + +(|>|) :: StreamTrans i m a -> StreamTrans m o b -> StreamTrans i o b +_ |>| Return b = Return b +ReadS f |>| stream = ReadS (\input -> (f input) |>| stream) +WriteS out stream |>| ReadS f = stream |>| f (Just out) +stream1 |>| WriteS out stream2 = WriteS out (stream1 |>| stream2) +stream |>| ReadS f = stream |>| f Nothing + +-- Zadanie 8 + +catchOutput :: StreamTrans i o a -> StreamTrans i b (a, [o]) +catchOutput = aux [] + where + aux xs (Return a) = Return (a, xs) + aux xs (ReadS f) = ReadS (\i -> aux xs (f i)) + aux xs (WriteS out stream) = aux (out : xs) stream + +-- Zadanie 9 + +data BF + = MoveR -- > + | MoveL -- < + | Inc -- + + | Dec -- - + | Output -- . + | Input -- , + | While [BF] -- [ ] + deriving Show + +brainfuckParser :: StreamTrans Char BF Bool +brainfuckParser = ReadS $ \x -> case x of + Nothing -> Return False + Just '>' -> WriteS MoveR brainfuckParser + Just '<' -> WriteS MoveL brainfuckParser + Just '+' -> WriteS Inc brainfuckParser + Just '-' -> WriteS Dec brainfuckParser + Just '.' -> WriteS Output brainfuckParser + Just ',' -> WriteS Input brainfuckParser + Just '[' -> do (b, loop) <- catchOutput brainfuckParser + if b then WriteS (While loop) brainfuckParser + else Return False + Just ']' -> Return True + Just _ -> brainfuckParser + +-- Zadanie 10 + +type Tape = ([Integer], [Integer]) +evalBF :: Tape -> BF -> StreamTrans Char Char Tape +evalBF (xs, y : ys) MoveR = Return (y : xs, ys) +evalBF (x : xs, ys) MoveL = Return (xs, x : ys) +evalBF (xs, y : ys) Inc = Return (xs, (y + 1) : ys) +evalBF (xs, y : ys) Dec = Return (xs, (y - 1) : ys) +evalBF (xs, y : ys) Output = WriteS (coerceEnum y :: Char) (Return (xs, y : ys)) +evalBF (xs, y : ys) Input = ReadS (\i -> case i of + Nothing -> Return (xs, y : ys) + Just i -> Return (xs, (coerceEnum i :: Integer) : ys)) +evalBF (xs, y : ys) (While loop) = + if y == 0 then Return (xs, y : ys) + else do + loopTape <- evalBFBlock (xs, y : ys) loop + evalBF loopTape (While loop) + +evalBFBlock :: Tape -> [BF] -> StreamTrans Char Char Tape +evalBFBlock tape [] = Return tape +evalBFBlock tape (bf : bfcode) = + do result <- evalBF tape bf + evalBFBlock result bfcode + +coerceEnum :: (Enum a, Enum b) => a -> b +coerceEnum = toEnum . fromEnum + +runBF :: [BF] -> StreamTrans Char Char () +runBF bfcode = do evalBFBlock (repeat 0, repeat 0) bfcode + return () + +runIOStreamTransWithHandles :: Handle -> Handle -> StreamTrans Char Char a -> IO a +runIOStreamTransWithHandles inp out (Return a) = return a +runIOStreamTransWithHandles inp out (ReadS f) = do + eof <- hIsEOF inp + if eof then + runIOStreamTransWithHandles inp out $ f Nothing + else do + ch <- hGetChar inp + runIOStreamTransWithHandles inp out $ f (Just ch) +runIOStreamTransWithHandles inp out (WriteS o str) = do + hPutChar out o + runIOStreamTransWithHandles inp out str + +runIOStreamTrans :: StreamTrans Char Char a -> IO a +runIOStreamTrans = runIOStreamTransWithHandles stdin stdout + +instance Functor (StreamTrans i o) where + fmap f (Return a) = Return $ f a + fmap f (ReadS g) = ReadS $ fmap f . g + fmap f (WriteS o s) = WriteS o $ fmap f s + +instance Applicative (StreamTrans i o) where + Return f <*> s = fmap f s + WriteS o sf <*> sa = WriteS o (sf <*> sa) + ReadS g <*> s = ReadS $ (<*> s) . g + pure = Return + +instance Monad (StreamTrans i o) where + Return a >>= f = f a + ReadS g >>= f = ReadS $ (>>= f) . g + WriteS o s >>= f = WriteS o (s >>= f) + +-- main = do +-- filename : _ <- getArgs +-- handle <- openFile filename ReadMode +-- (_, bfs) <- runIOStreamTransWithHandles handle handle $ catchOutput brainfuckParser +-- runIOStreamTrans $ runBF bfs + + +data BT a = L a | N (BT a) (BT a) + -- deriving show + +tt = N (N (N (L 1) (L 2)) (L 4)) (L 3) + +traverseBt :: BT a -> [a] +traverseBt (L x) = [x] +traverseBt (N tl tr) = (traverseBt tr) ++ (traverseBt tl) + +witaj :: IO () +witaj = putStr
\ No newline at end of file |