module Sprintf where

int :: (String -> a) -> String -> Integer -> a
int k s n = k $ s ++ show n

str :: (String -> a) -> String -> String -> a
str k s t = k $ s ++ t

lit :: String -> (String -> a) -> String -> a
lit l k s = k $ s ++ l

($$) f g k = f $ g k

sprintf fmt = fmt id ""

--- 

--- type Format a b = (String -> b) -> String -> a

-- type Format a b =
--   Lit String 


data Format a b where
     Lit   :: String -> Format a a -- a
     IInt  :: Format (Int -> a) a -- (Int ->
     Str   :: Format (String -> a) a
     (:^:) :: (Format a b) -> (Format b c) -> (Format a c)

ksprintf :: Format a b -> (String -> b) -> a
ksprintf (Lit string) fun = fun string
ksprintf IInt fun = fun . show  --  \x -> fun (show x)
ksprintf Str fun = fun 
ksprintf (format1 :^: format2) fun =
  ksprintf format1 (\s -> ksprintf format2 (\t -> fun (s ++ t)))

kprintf :: Format a b -> (IO () -> b) -> a
kprintf (Lit string) fun = fun $ putStr string
kprintf IInt fun = fun . putStr . show  --  \x -> fun (show x)
kprintf Str fun = fun . putStr
kprintf (format1 :^: format2) fun =
  kprintf format1 (\s -> kprintf format2 (\t -> fun (s >> t))) -- s :: IO 

printf format = kprintf format id


printf ((Lit "ile") :^: IInt) 10

import Data.Char

data StreamTrans i o a
  = Return a
  | ReadS (Maybe i -> StreamTrans i o a)
  | WriteS o (StreamTrans i o a)

toLowerTrans :: StreamTrans Char Char ()

read Nothing = Return ()
read (Just char) = WriteS (toLower char) toLowerTrans
toLowerTrans = ReadS Main.read

runIOStreamTrans :: StreamTrans Char Char a -> IO a

runIOStreamTrans (Return a) = return a
runIOStreamTrans (ReadS action) = System.IO.isEOF >>= \x -> if x
                                                      then runIOStreamTrans (action Nothing)
                                                      else getChar >>= \y -> runIOStreamTrans (action (Just y))
                                                                                                      
runIOStreamTrans (WriteS char streamTrans) = do
                                               putChar char
                                               runIOStreamTrans streamTrans
main = runIOStreamTrans toLowerTrans

# Lista 11

class Monad m => Random m where -- m :: * -> *
  random :: m Int

shuffle :: Random m => [a] -> m [a]
shuffle = do
  x <- random
  return [x]

insert_nth :: a -> [a] -> Int -> [a]
insert_nth a [] _ = [a]
insert_nth a ls 0 = a : ls
insert_nth a (hd:tl) n = hd : (insert_nth a tl (n-1))

shuffle [] = return []
shuffle (hd:tl) = do
                  len = length tl
                  ind <- random   -- >>= :: Monad m => m a -> (a -> m b) -> m b
                  ind = ind `mod` len
                  perm <- shuffle tl --
                  return $ insert_nth hd perm ind


shuffle (hd:tl) = random >>= (\ind -> shuffle tl >>= (\perm -> return $ insert_nth hd perm ind))

Zad 2

import Control.Monad (liftM, ap)

class Monad m => Random m where
random :: m Int

newtype RS a = RS {unRS :: Int -> (Int, a)}

--unzip':: RS a -> Int -> (Int,a)
--unzip' (RS record) = record

withSeed :: RS a -> Int -> a
withSeed roll seed =
snd ((unRS roll) seed)

instance Functor RS where
fmap = liftM

instance Applicative RS where
pure a = RS (\x -> (x,a))
(<*>) = ap

instance Monad RS where
initRoll >>= nextAction =
RS $ \seed ->
let (interSeed,interResult) = unRS initRoll seed
in unRS (nextAction interResult) interSeed

instance Random RS where
random = RS (\x -> (x+1,x)) -- example

xd :: RS [Int]
xd = do
x <- random
y <- random
return [x, y]

withSeed xd 1

ls = [1,2,3,4,5]

Zad 3

{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies #-}

class Monad m => TwoPlayerGame m s a b | m -> s a b where
moveA :: s -> m a
moveB :: s -> m b

-- initialBoard >>= moveA >>= moveB >>= moveA >>=
type Square = A | X | B
type Board = ((Square,Square,Square), (Square,Square,Square), (Square,Square,Square))
deriving Show

initialBoard = return ((X,X,X), (X,X,X), (X,X,X))

data Score = AWins | Draw | BWins

game' :: TwoPlayerGame m Board AMove BMove => Who -> Board -> m Score
game' w s =
if gameOver s then
return $ getScore s
if isFirst w then
a <- moveA s
s' <- makeMoveA s a
game' (otherPlayer w) s'
else
b <- moveB s
s' <- makeMoveB s b
game' (otherPlayer w) s'

game :: TwoPlayerGame m Board AMove BMove => m Score
game = do
s <- initialBoard
game' s

Zad 4

{-# LANGUAGE FlexibleContexts, FlexibleInstances, FunctionalDependencies #-}

import Control.Monad (liftM, ap)

class Monad m => TwoPlayerGame m s a b | m -> s a b where
moveA :: s -> m a
moveB :: s -> m b

newtype IOGame s a b x = IOGame { runIOGame :: IO x }

instance Functor (IOGame s a b) where
fmap = liftM

instance Applicative (IOGame s a b) where
pure a = IOGame $ do {return a}
(<*>) = ap

-- (>>=) :: m x -> (x -> m y) -> m y , m = IOGame s a b
instance Monad (IOGame s a b) where
move >>= action = IOGame ((runIOGame move) >>= (\m -> runIOGame $ action m))

instance (Show s, Read a, Read b) => TwoPlayerGame (IOGame s a b) s a b where
-- moveA s -> (IOGame s a b a)
moveA s = IOGame $ do
putStr $ show s
ln <- getLine
return $ read ln
moveB s = IOGame $ do
putStr $ show s
ln <- getLine
return $ read ln

---------------------------------------------
    • Found hole: _ :: IOGame s a b b1
      Where: ‘b1’ is a rigid type variable bound by
               the type signature for:
                 (>>=) :: forall a1 b1.
                          IOGame s a b a1 -> (a1 -> IOGame s a b b1) -> IOGame s a b b1
               at zad4.hs:21:9-11
             ‘s’, ‘a’, ‘b’ are rigid type variables bound by
               the instance declaration
               at zad4.hs:20:10-29
    • In a stmt of a 'do' block: _
      In the expression:
        do let mv = runIOGame move
           _
      In an equation for ‘>>=’:
          move >>= action
            = do let mv = ...
                 _
    • Relevant bindings include
        mv :: IO a1 (bound at zad4.hs:22:28)
        action :: a1 -> IOGame s a b b1 (bound at zad4.hs:21:13)
        move :: IOGame s a b a1 (bound at zad4.hs:21:4)
        (>>=) :: IOGame s a b a1
                 -> (a1 -> IOGame s a b b1) -> IOGame s a b b1
          (bound at zad4.hs:21:9)
   |
23 |                        _
   |                        ^
----------------------------