Cvičení z Neprocedurálního programování (NPRG005)

Tomáš Křen (tomkren na džímejlu kom)

Pá od 10:40 v S1

Info k zápočtovému programu

13. cvičení

import Data.List


data Paska s = Paska [s] s [s]

class (Show s) => Sym s where
  empty :: s
  showSyms :: [s] -> String
  showSyms = concat . map show

instance Sym Char where
  empty = ' ' 

instance Sym Int where
  empty = 0
  showSyms = concat . intersperse "," . map show


mkPaska :: (Sym s) => [s] -> Paska s
mkPaska [] = Paska [] empty []
mkPaska (x:xs) = Paska [] x xs

instance (Sym s) => Show (Paska s) where
  show (Paska xs s ys) = 
    (showSyms . reverse $ xs) ++ "["++(show s)++"]" ++ (showSyms ys)



moveHeadLeft :: (Sym s) => Paska s -> Paska s
moveHeadLeft (Paska [] s ys)     = Paska [] empty (s:ys)
moveHeadLeft (Paska (x:xs) s ys) = Paska xs x     (s:ys)


moveHeadRight :: (Sym s) => Paska s -> Paska s
moveHeadRight (Paska xs s [])     = Paska (s:xs) empty []
moveHeadRight (Paska xs s (y:ys)) = Paska (s:xs) y     ys


data Move = L | N | R deriving (Show)


moveHead :: (Sym s) => Move -> Paska s -> Paska s
moveHead move = case move of
  L -> moveHeadLeft
  N -> id
  R -> moveHeadRight

type StepFun q s = (q,s) -> Maybe (q,s,Move)

data TM q s = TM {
  stepFun :: StepFun q s,
  initState :: q,
  finStates :: [q]
}


data TMConfig q s = TMConfig q (Paska s)

class (Show q, Eq q) => State q where


instance (State q, Sym s) => Show (TMConfig q s) where
  show (TMConfig q paska) = "<"++(show q)++"> "++(show paska)


data StepResult q s = Next (TMConfig q s) | Halt (TMConfig q s) | Fail

tmStep :: (State q, Sym s) => TM q s -> TMConfig q s -> StepResult q s
tmStep tm (TMConfig q (Paska xs s ys)) = case stepFun tm (q,s) of
  Nothing -> Fail
  Just (q',s',move) -> 
    let paska' = moveHead move (Paska xs s' ys)
        resultCons = if q' `elem` finStates tm then Halt else Next
     in resultCons $ TMConfig q' paska'



tmRun :: (State q, Sym s) => TM q s -> [s] -> IO ()
tmRun tm input = run $ TMConfig (initState tm) (mkPaska input)
  where
    putConfig = putStrLn . show
    run config = do
      putConfig config
      case tmStep tm config of
        Next config' -> run config'
        Halt config' -> putConfig config'
        Fail -> return ()  


-- Busy Beaver : https://en.wikipedia.org/wiki/Busy_beaver

instance State Int where


bb3 :: StepFun Int Char
bb3 x = case x of
  (1,' ') -> Just (2,'*',R)
  (1,'*') -> Just (3,'*',L)
  (2,' ') -> Just (1,'*',L)
  (2,'*') -> Just (2,'*',R)
  (3,' ') -> Just (2,'*',L)
  (3,'*') -> Just (4,'*',R)


tmBB3 :: TM Int Char
tmBB3 = TM {
  initState = 1,
  finStates = [4],
  stepFun = bb3
}

12. cvičení

cv12.hs :

{-# LANGUAGE FlexibleInstances #-}

import Text.JSON

import WebServer


data Tree a = Tree a [Tree a]


treeFold :: (a -> [acc] -> acc) -> Tree a -> acc
treeFold f (Tree x ts) = f x $ map (treeFold f) ts


data Expr op val = Expr op (Expr op val) (Expr op val) | Val val deriving (Show,Read)


exprFold :: (op->acc->acc->acc) -> (val->acc) -> Expr op val -> acc
exprFold fNode fLeaf = g
 where g (Val x) = fLeaf x
       g (Expr op e1 e2) = fNode op (g e1) (g e2) 


-- exprFold' :: ((a->a->a) -> (acc->acc->acc)) 

evalExpr :: (Expr (a->a->a) a) -> a
evalExpr = exprFold id id


e1 = Val 1
e2 = Expr (+) (Val 2) (Val 4)

type Dic val = String -> val -> val -> val

dic1 "+" = (+)
dic1 "-" = (-)
dic1 "*" = (*)
dic1 "/" = (/)

evalExprDic :: Dic val -> (Expr String val) -> val
evalExprDic dic = exprFold dic id

e3 = Val 1
e4 = Expr "+" (Val 2) (Val 4)
e5 = Expr "*" (Val 7.0) (Expr "+" (Val 2.0) (Val 4.0))

-- showJSON :: JSON a => a -> JSValue
-- readJSON :: JSON a => JSValue -> Result a

instance JSON (Expr String Double) where
  showJSON e = case e of
    Val x -> showJSON x
    Expr op e1 e2 -> showJSON $ [showJSON op, showJSON e1, showJSON e2]
  readJSON jsVal = case jsVal of
    JSArray [jsOp,jsE1,jsE2] -> do
      op <- readJSON jsOp
      e1 <- readJSON jsE1
      e2 <- readJSON jsE2
      Ok $ Expr op e1 e2
    JSRational _ x -> Ok . Val . fromRational $ x
    _ -> Error "Unsupported format."   


evalExprJson :: Dic Double -> String -> Result Double
evalExprJson dic jsonStr = case decode jsonStr of
  Ok expr -> Ok $ evalExprDic dic expr
  Error msg -> Error msg

runEvalServer :: IO ()
runEvalServer = runWebServer 80 evalServerFun

evalServerFun :: String -> String
evalServerFun reqStr = case evalExprJson dic1 reqStr of
  Ok x -> show x
  Error msg -> msg

WebServer.hs :

{-# LANGUAGE OverloadedStrings #-}

module WebServer (runWebServer) where


-- https://hackage.haskell.org/package/wai

import Network.Wai (Application, Response, responseLBS, rawPathInfo)
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types (status200)
import Network.HTTP.Base  (urlDecode)

import qualified Data.ByteString.Lazy as BsLazy
import qualified Data.ByteString.UTF8 as BsUTF
import qualified Data.Text as T
import qualified Data.Text.Encoding as E

type Port = Int

--  example  -----------------------------------------------------------

exampleServerFun :: String -> String
exampleServerFun cmd = "{\"cmd\":\""++ cmd ++"\"}"

runExample :: IO ()
runExample = runWebServer 8080 exampleServerFun

--  exported functions  ------------------------------------------------

runWebServer :: Port -> (String -> String) -> IO ()
runWebServer port serverFun = do
  putStrLn $ "Server running at http://localhost:" ++ show port ++ "/"
  run port $ mkApp serverFun

------------------------------------------------------------------------

mkApp :: (String -> String) -> Application
mkApp serverFun request respond = respond . jsonResponse . serverFun . processPath . rawPathInfo $ request

jsonResponse :: String -> Response
jsonResponse jsonStr = responseLBS status200 jsonContentType $ str2lazy jsonStr
  where jsonContentType = [("Content-Type", "application/json; charset=utf-8")]

processPath :: BsUTF.ByteString -> String
processPath = urlDecode . T.unpack . trimSlashes . E.decodeUtf8

str2lazy :: String -> BsLazy.ByteString
str2lazy = BsLazy.fromStrict . BsUTF.fromString

trimSlashes :: T.Text -> T.Text
trimSlashes = T.dropWhile isSlash . T.dropWhileEnd isSlash
  where isSlash = (=='/')

11. cvičení

data Mozna a = Nic | Proste a deriving (Show)


instance Functor Mozna where
  fmap f mx = case mx of
    Nic -> Nic
    Proste x -> Proste (f x)

instance Applicative Mozna where
   pure = Proste
   mf <*> mx = case mf of
    Nic -> Nic
    Proste f -> fmap f mx

instance Monad Mozna where
  mx >>= f = case mx of
    Nic -> Nic
    Proste x -> f x


safeLog :: Double -> Mozna Double
safeLog x | x <= 0    = Nic
          | otherwise = Proste (log x)

safeSqrt :: Double -> Mozna Double
safeSqrt x | x < 0     = Nic
           | otherwise = Proste (sqrt x)


mSafeLog :: Double -> Maybe Double
mSafeLog x | x <= 0    = Nothing
          | otherwise = Just (log x)

mSafeSqrt :: Double -> Maybe Double
mSafeSqrt x | x < 0     = Nothing
           | otherwise = Just (sqrt x)


safeSqrtLog :: Double -> Mozna Double
safeSqrtLog x = case safeLog x of
  Nic -> Nic
  Proste y -> safeSqrt y



najdi :: Eq a => [a] -> a -> Mozna Int
najdi xs y = f xs 0
  where f  [] _ = Nic
        f  (x:xs) n | x == y    = Proste n
                    | otherwise = f xs (n+1)


safeHead :: [a] -> Mozna a
safeHead [] = Nic
safeHead (x:_) = Proste x


najdiPrvni :: Eq a => [a] -> [a] -> Mozna Int
najdiPrvni xs ys = case safeHead ys of
  Nic -> Nic
  Proste y -> najdi xs y


lbind :: (a -> Mozna b) -> Mozna a -> Mozna b
lbind f mx = case mx of
  Nic -> Nic
  Proste x -> f x

rbind :: Mozna a -> (a -> Mozna b) -> Mozna b
rbind = flip lbind 

bSafeSqrtLog :: Double -> Mozna Double
bSafeSqrtLog x = lbind safeSqrt (safeLog x)

bNajdiPrvni :: Eq a => [a] -> [a] -> Mozna Int
bNajdiPrvni xs ys = lbind (najdi xs) (safeHead ys)





rSafeSqrtLog :: Double -> Maybe Double
rSafeSqrtLog x =  (mSafeLog x) >>= mSafeSqrt 


doSafeSqrtLog :: Double -> Maybe Double
doSafeSqrtLog x = do
  y <- mSafeLog x     
  mSafeSqrt y

-- mSafeLog x >>= (\y -> mSafeSqrt y)


-- PISKVORKY -------------------------------


startDeska = "....x...."

showDeska :: [Char] -> String
showDeska xs = "\n" ++
  take 3 xs ++ "\n" ++
  take 3 (drop 3 xs) ++ "\n" ++
  take 3 (drop 6 xs) ++ "\n"


dalsiDesky :: Char -> [Char] -> [[Char]]
dalsiDesky hrac deska = f ([],deska)
  where f (_,[]) = []
        f (xs,y:ys) | y == '.'  = (xs++(hrac:ys)) : f (xs++[y], ys)
                    | otherwise = f (xs++[y], ys)


showDesky :: [[Char]] -> String
showDesky = concat . map showDeska

putDesky :: [[Char]] -> IO ()
putDesky = putStrLn . showDesky
 
poJednom :: [[Char]]
poJednom = dalsiDesky 'o' startDeska

poDvouTazich :: [[Char]]
poDvouTazich = concat $ map (dalsiDesky 'x') (dalsiDesky 'o' startDeska)

bPoDvouTazich = [startDeska] >>= dalsiDesky 'o' >>= dalsiDesky 'x'

doPoDvouTazich = do
  a <- [startDeska]
  b <- dalsiDesky 'o'
  dalsiDesky 'x'


-- Dů:
verze1 = [ (x,y) | x <- xs , y <- ys , x + y > 10 ]

{-

Udělejte funkci sraz, aby fungovalo
verze2 = do 
  x <- xs
  y <- ys
  straz (x + y > 10)
  return (x,y)

-}

10. cvičení

-- Dů (1) : isInside :: Tvar -> Bod -> Bool

type Bod = (Double,Double)
type Polomer = Double
data Tvar = Obdelnik Bod Bod | Kruh Bod Polomer | Trojuhelnik Bod Bod Bod


-- (2) Pro tento typ stromu udělejte fold
data Tree a = Tree a [Tree a]

-- (3) Definujte datový typ pro herní karty

-- (4*) Navrhněte datovou strukturu pro aritm výraz 
--      a udělejte vyhodnocení pomocí foldu.


--------------------------



mensiNez n xs = [ 2*x | x <- xs , x < n]

mensiNez2 n = map (2*) . filter ( t -> [t] -> [t] -> [(t, t)]
allPairsVeciNez n xs ys = [(x,y) | x <- xs, y <-ys, x+y > n] 

delitele :: Integer -> [Integer]
delitele n = [ x | x <- [1..n] , n `mod` x == 0]

cislaADelitele = [ (n, delitele n) | n <- [1..] ]



-----------------------------------------------


-- data Bool = False | True

data Barva = Cervena | Zelena | Modra | Cerna | Bila --deriving --(Show,Eq,Ord,Enum,Read)

instance Show Barva where
  show b = case b of
    Cervena -> "C"
    Zelena  -> "Z"
    Modra   -> "M"
    Cerna   -> "Cerna"
    Bila    -> "B"

barvaNaRGB :: Barva -> (Int,Int,Int)
barvaNaRGB b = case b of
 Cervena -> (255,0,0)
 Zelena  -> (0,255,0)
 Modra   -> (0,0,255)
 Cerna   -> (0,0,0)
 Bila    -> (255,255,255)


data BarvaRGB = CervenaRGB 
              | ZelenaRGB 
              | ModraRGB 
              | CernaRGB 
              | BilaRGB
              | RGB Int Int Int






data Dvojice a = D a a deriving (Show)

data Pair a b = Pair a b 

prvni :: Pair a b -> a
prvni (Pair x _) = x

druhy :: Pair a b -> b
druhy (Pair _ x) = x

naTuple :: Pair a b -> (a,b)
naTuple (Pair x y) = (x,y)



---

data Strom a = Uzel (Strom a) a (Strom a) | Nil





pridej :: (Ord a) => Strom a -> a -> Strom a
pridej Nil x = Uzel Nil x Nil
pridej (Uzel t1 val t2) x 
  | x < val   = Uzel (pridej t1 x) val t2
  | otherwise =  Uzel t1 val (pridej t2 x)

list2bst :: (Ord a) => [a] -> Strom a
list2bst xs = foldl pridej Nil xs



showStrom :: (Show a) => Strom a -> [String]
showStrom Nil = []
showStrom (Uzel t1 val t2) = 
  let odsad str = "  " ++ str
      radkyUzlu = (showStrom t2) ++ [show val] ++ (showStrom t1)
   in map odsad radkyUzlu

instance Show a => Show (Strom a) where
  show tree = unlines $ showStrom tree


data List a = Cons a (List a) | Empty


myFoldr :: (a -> b -> b) -> b -> (List a -> b)
myFoldr fCons vEmpty Empty = vEmpty
myFoldr fCons vEmpty (Cons x xs) = fCons x (myFoldr fCons vEmpty xs)

myFoldr2 :: (a -> b -> b) -> b -> (List a -> b)
myFoldr2 fCons vEmpty = g where
  g Empty = vEmpty
  g (Cons x xs) = fCons x (g xs)


stromFold :: (b -> a -> b -> b) -> b -> Strom a -> b
stromFold fUzel vNil Nil = vNil
stromFold fUzel vNil (Uzel t1 val t2) = 
  fUzel (stromFold fUzel vNil t1) val (stromFold fUzel vNil t2)

stromFold2 :: (b -> a -> b -> b) -> b -> Strom a -> b
stromFold2 fUzel vNil = g where
  g Nil = vNil
  g (Uzel t1 val t2) = fUzel (g t1) val (g t2)


bst2list :: Strom a -> [a]
bst2list tree = stromFold (\ xs val ys -> xs ++ [val] ++ ys) [] tree

9. cvičení

import Data.List
import Data.Char

split :: (a -> Bool) -> [a] -> ([a],[a])
split p xs = foldr f ([],[]) xs
  where
    f x (xs,ys) | p x       = (x:xs,ys)
                | otherwise = (xs,x:ys)


split2 :: (a -> Bool) -> [a] -> ([a],[a])
split2 p = foldr (\ x (xs,ys) -> if p x then (x:xs,ys) else (xs,x:ys)) ([],[])


curry' :: ((a,b) -> c) -> (a -> (b -> c))
--curry f = \ x -> (\ y -> f (x,y))
curry' f x y = f (x,y)

-- \ x y z -> ...
-- \ x -> (\ y -> ( \ z -> ... ))

uncurry' :: (a -> b -> c) -> (a,b) -> c
uncurry' f (x,y) = f x y


flip' :: (a -> b -> c) -> b -> a -> c
flip' f y x = f x y

-- zretez seznamy
(+++) :: [a] -> [a] -> [a]
(+++) xs ys = foldr (:) ys xs

concat' :: [[a]] -> [a]
concat' = foldr (+++) []

sum' :: Num a => [a] -> a
sum' = foldl (+) 0

prod' :: Num a => [a] -> a
prod' = foldl (*) 1


len :: [a] -> Int
len = foldr (\_->(+1)) 0


map' :: (a -> b) -> [a] -> [b]
map' f = foldr (\ x-> ((f x) :)) []


filter' :: (a -> Bool) -> [a] -> [a]
filter' p xs = foldr (\ x acc -> if p x then x:acc else acc) [] xs



horner :: Num a => [a] -> a
horner xs = foldl (\acc x-> acc * 10 + x) 0 xs

readCifra :: Char -> Int
readCifra ch = ord ch - ord '0'

-- ($) :: (a -> b) -> a -> b
-- f $ x = f x

-- (.) :: (b->c) -> (a->b) -> (a->c) 
-- (g . f) x = g (f x) 

readInt :: [Char] -> Int
readInt str = horner ( map readCifra str )

readInt' :: String -> Int
readInt' str = foldl (\acc x-> acc * 10 + x) 0 $ map readCifra str 

readInt'' :: String -> Int
readInt'' =  (foldl (\acc x-> acc * 10 + x) 0) . (map readCifra)

readInt''' :: String -> Int
readInt''' =  foldl ((+).(*10)) 0 . map (((-)(ord '0')).ord) 





ss :: Num a => [a] -> [a] -> a
ss x = sum . (zipWith (*) x) 

-- boobs operator (.).(.)
 
-- proč nefunguje?
-- ss'  = sum ((.).(.)) (zipWith (*))


my_foldl f a bs = (foldr (\ b g -> (\x ->  g (f x b)  )) id bs) a

8. cvičení

Domácí úkol: Napište ekvivalent funkce filter, která (místo toho, aby vracela seznam elementů, které splní podmínku) vrací dvojici seznamů: První s elementy, které podmínku splňují; druhý s elementy, které podmínku nesplňují. Implementujte funkci tak, aby prošla seznam jen jednou (tzn ne "dvakrát filter"). 

fac :: Integer -> Integer
fac n | n < 0     = error "To nechces!"
      | n == 0    = 1
      | otherwise = n * fac (n-1)


fac2 n = if n == 0 then 1 else n * fac2 (n-1)

my_map :: (a -> b) -> [a] -> [b]
my_map _ [] = []
my_map f (x:xs) = (f x) : (my_map f xs)

my_take :: Int -> [a] -> [a]
my_take 0 _  = []
my_take _ [] = []
my_take n (x:xs) | n < 0     = error "n musí byt nezaporny"
                 | otherwise = x : (my_take (n-1) xs)


my_takeWhile :: (a -> Bool) -> [a] -> [a]
my_takeWhile _ [] = []
my_takeWhile f (x:xs) | f x       = x : (my_takeWhile f xs)
                      | otherwise = []


seznamDruhychMocnin = map (2^) [1..]


my_zip :: [a] -> [b] -> [(a,b)]
my_zip [] _ = []
my_zip _ [] = []
my_zip (x:xs) (y:ys) = (x,y) : (my_zip xs ys)


my_zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
my_zipWith _ [] _ = []
my_zipWith _ _ [] = []
my_zipWith f (x:xs) (y:ys) = (f x y) : (my_zipWith f xs ys)




-- 0 [1,2,3,4,5]
-- (((((0 + 1) + 2) + 3) + 4) + 5)


my_foldl :: (a -> b -> a) -> a -> [b] -> a
my_foldl _ acc [] = acc
my_foldl f acc (x:xs) = my_foldl f (f acc x) xs

-- [1,2,3,4,5] 0
-- 1 + (2 + (3 + (4 + (5 + 0))))


my_foldr :: (b -> a -> a) -> a -> [b] -> a
my_foldr _ z [] = z
my_foldr f z (x:xs) = f x (my_foldr f z xs)


my_foldl1 :: (a->a->a) -> [a] -> a
my_foldl1 f (x:xs) = my_foldl f x xs

skals :: Num a => [a] -> [a] -> a
skals x y = my_foldl1 (+) (my_zipWith (*) x y)

suma :: Num a => [a] -> a
--sum xs = my_foldl1 (+) xs
suma = my_foldl1 (+)



my_filter :: (a -> Bool) -> [a] -> [a]
my_filter _ [] = []
my_filter p (x:xs)
 | p x       = x : (my_filter p xs)
 | otherwise = my_filter p xs

6. cvičení

% ulice(dum(barva,skola,jazyk,firma,zvire),...)

uliceMaDum(ulice(D1,D2,D3,D4,D5),D) :-
  D=D1; D=D2; D=D3; D=D4; D=D5.


napravo(ulice(D1,D2,D3,D4,D5),Da,Db) :-
  (Db=D1,Da=D2);
  (Db=D2,Da=D3);
  (Db=D3,Da=D4);
  (Db=D4,Da=D5).

vedle(U,Da,Db) :- napravo(U,Da,Db) ; napravo(U,Db,Da).

posledni(ulice(_,_,_,_,D),D).
prostredni(ulice(_,_,D,_,_),D).

okUlice(U) :-
  uliceMaDum(U,dum(_,mff,prolog,_,_)),
  uliceMaDum(U,dum(red,zcu,_,_,_)),
  uliceMaDum(U,dum(_,cvut,_,_,pes)),
  uliceMaDum(U,dum(_,up,_,microsoft,_)),
  posledni(U,dum(_,mu,_,_,_)),
  uliceMaDum(U,dum(_,_,swift,apple,_)),
  uliceMaDum(U,dum(yellow,_,haskell,_,_)),
  uliceMaDum(U,dum(_,_,lisp,_,papusek)),
  uliceMaDum(U,dum(green,_,_,google,_)),

  vedle(U, dum(_,_,lisp,_,_), dum(_,_,_,_,kocka)),
  vedle(U, dum(_,_,_,_,kun), dum(_,_,haskell,_,_)),
  vedle(U, dum(_,_,fsharp,_,_), dum(_,_,_,ibm,_)),
  napravo(U, dum(green,_,_,_,_), dum(orange,_,_,_,_)),
  vedle(U, dum(_,mu,_,_,_), dum(blue,_,_,_,_)),
  prostredni(U, dum(_,_,_,facebook,_)),

  uliceMaDum(U,dum(_,_,_,_,zebra)).



%-----------------------------------------------



% akce(+Stav1, +Obj1, +Obj2, -Stav2).

% vyleju první
akce(s(_,Y), _,_, s(0,Y)).
% vyleju druhou
akce(s(X,_), _,_, s(X,0)).
% naplnim první
akce(s(_,Y), Obj1,_, s(Obj1,Y)).
% naplnim druhou
akce(s(X,_), _,Obj2, s(X,Obj2)).

% preleju druhou do prvni, nevejde se
akce(s(X,Y), Obj1,_, s(Obj1,Y1)) :-
  X + Y > Obj1,
  Y1 is X+Y - Obj1.
%preleju druhou do prvni, vejde se
akce(s(X,Y), Obj1,_, s(X1,0)) :-
  X + Y =< Obj1,
  X1 is X + Y.

% preleju prvni do druhy, nevejde se
akce(s(X,Y), _,Obj2, s(X1,Obj2)) :-
  X + Y > Obj2,
  X1 is X+Y - Obj2.
%preleju prvni do druhy, vejde se
akce(s(X,Y), _,Obj2, s(0,Y1)) :-
  X + Y =< Obj2,
  Y1 is X + Y.




%nkroku(+Stav, +Obj1, +Obj2, +PocetKroku, -StavPoNKrocích).

nkroku(S, _, _, 0, S).
nkroku(S, Obj1, Obj2, N, StavPoN) :-
  N > 0,
  akce(S, Obj1, Obj2, S1),
  N1 is N - 1,
  nkroku(S1, Obj1, Obj2, N1, StavPoN).




% nkroku(+Stav, +Obj1, +Obj2, +PocetKroku, -PoslStavu, -KonStav).

nkroku(S, Obj1, Obj2, N, Posl, KonStav) :-
  nkroku(S, Obj1, Obj2, N, [S], Posl, KonStav).

nkroku(S, _,_, 0, Acc, Posl, S) :- reverse(Acc,Posl).
nkroku(S, Obj1, Obj2, N, Acc, Posl, KonStav) :-
  N > 0,
  akce(S, Obj1, Obj2, S1),
  \+member(S1,Acc),
  N1 is N - 1,
  nkroku(S1, Obj1,Obj2, N1, [S1|Acc], Posl, KonStav).



% vyresID(+PocatecniStav, +Obj1, +Obj2, +KonStav, -Posl).

vyresID(PS, Obj1,Obj2, KonStav, Posl) :-
  vyresID(PS, Obj1,Obj2, 1, KonStav, Posl).


% vyresID(+PocatecniStav, +Obj1, +Obj2, +Hloubka,+KonStav, -Posl).

vyresID(PS, Obj1,Obj2, Hloubka, KonStav, Posl) :-
  nkroku(PS, Obj1,Obj2, Hloubka, Posl, KonStav).
vyresID(PS, Obj1,Obj2, Hloubka, KonStav, Posl) :-
  Hloubka1 is Hloubka + 1,
  Hloubka1 < 50,
  vyresID(PS, Obj1,Obj2, Hloubka1, KonStav, Posl).

5. cvičení

% -- Rozdílové seznamy -----------------------------

naRozdil([],X-X).
naRozdil([H|T], [H|L]-X) :- naRozdil(T,L-X).

naKlasik(L-[], L).

spoj1(L1-X1, L2-X2, L3-X3) :- X1=L2, L3=L1, X3=X2.

spoj(L1-L2, L2-X2, L1-X2).

% -- FLATTEN -----------------------------------------

flatten([],[]).
flatten([X|Xs], Res) :-
  flatten(X,FlatX),
  flatten(Xs,FlatXs),
  append(FlatX,FlatXs,Res),
  !.
flatten(X,[X]).


flatten2(Xs,Res) :- difflat(Xs,Res-[]).


difflat([],X-X).
/* difflat([X|Xs], Res) :-
  difflat(X,FlatX),
  difflat(Xs,FlatXs),
  spoj(FlatX,FlatXs,Res),
  !.*/
difflat([X|Xs], Res-R) :-
  difflat(X,Res-FlatXs),
  difflat(Xs,FlatXs-R),
  !.
difflat(X,[X|XX]-XX).

% -- QUICKSORT ---------------------------------------

% partition(+Pivot, +Xs, -Maly, -Velky)

partition(_,     [],[],[]).
partition(Pivot, [X|Xs], [X|Maly], Velky) :-
  X =< Pivot,
  partition(Pivot, Xs, Maly, Velky).
partition(Pivot, [X|Xs], Maly, [X|Velky]) :-
  X > Pivot,
  partition(Pivot, Xs, Maly, Velky).


qsort([],[]).
qsort([X|Xs], Res) :-
  partition(X, Xs, Maly, Velky),
  qsort(Maly, MalySorted),
  qsort(Velky, VelkySorted),
  append(MalySorted, [X|VelkySorted], Res).



quicksort(Xs, Res) :- qs(Xs, Res-[]),!.

qs([],X-X).
qs([X|Xs], Res-R) :-
  partition(X,Xs, Maly, Velky),
  qs(Maly,  Res-[X|SVelky]),
  qs(Velky, SVelky-R).



% -- BINARNI STROMY ------------------------------------------------


% t(t(nil,2,nil),1,t(nil,3,nil))
% t(t(t(nil,4,nil),2,t(nil,5,nil)),1,t(nil,3,nil))

preList(nil, []).
preList(t(L,Node,R), [Node|Res]) :-
  preList(L,LRes),
  preList(R,RRes),
  append(LRes,RRes,Res).


preList2(Tree,Xs) :- preDL(Tree,Xs-[]).
preDL(nil, X-X).
preDL(t(L,Node,R), [Node|Res]-Tail) :-
  preDL(L, Res-RRes),
  preDL(R, RRes-Tail).



inList(nil, []).
inList(t(L,Node,R), Res) :-
  inList(L, LRes),
  inList(R, RRes),
  append(LRes,[Node|RRes],Res).


inList2(Tree,Xs) :- inDL(Tree,Xs-[]).
inDL(nil, X-X).
inDL(t(L,Node,R), Res-Tail) :-
  inDL(L, Res-[Node|RRes]),
  inDL(R, RRes-Tail).


postList(nil, []).
postList(t(L,Node,R), Res) :-
  postList(L,LRes),
  postList(R,RRes),
  append(RRes,[Node],RResNode),
  append(LRes,RResNode,Res).

postList2(Tree,Xs) :- postDL(Tree, Xs-[]).
postDL(nil, X-X).
postDL(t(L,Node,R), Res-Tail) :-
  postDL(L, Res-RRes),
  postDL(R, RRes-[Node|Tail]).


preorder(t(_,X,_),X).
preorder(t(L,_,_),X) :- preorder(L,X).
preorder(t(_,_,R),X) :- preorder(R,X).

inorder(t(L,_,_),X) :- inorder(L,X).
inorder(t(_,X,_),X).
inorder(t(_,_,R),X) :- inorder(R,X).

postorder(t(L,_,_),X) :- postorder(L,X).
postorder(t(_,_,R),X) :- postorder(R,X).
postorder(t(_,X,_),X).

4. cvičení

numBinOp(+).
numBinOp(-).
numBinOp(*).
numBinOp(/).

logBinOp(=).
logBinOp(\=).
logBinOp(=<).
logBinOp(>=).
logBinOp(<).
logBinOp(>).


def(inc, fun(x,[+,x,1])).
def(fac, fun(n,[if,[=,n,0],1,[*,n,[fac,[-,n,1] ] ]] ) ).


fromList([F|Xs], Term) :- fromList(Xs, F, Term).
fromList([],Acc,Acc).
fromList([X|Xs],Acc,Term) :- fromList(Xs,a(Acc,X),Term).


stepPlusOp(Term, Res) :-
  Term = a(a(+,X),Y),
  number(X), number(Y),
  Res is X + Y.

stepBinOp(Term, Res) :-
  Term = a(a(Op,X),Y),
  number(X), number(Y),
  ( logBinOp(Op), logOperate(Term,Res)
  ; numBinOp(Op), numOperate(Term,Res) ).


logOperate(a(a(Op,X),Y), true) :- call(Op,X,Y),!.
logOperate(a(a(_,_),_), false).


numOperate(a(a(Op,X),Y), Res) :-
  OpTerm =.. [Op,X,Y],
  Res is OpTerm.

step(X, Code) :-  def(X,Code).

step( a(a(a(if,true),X),_), X).
step( a(a(a(if,false),_),Y), Y).

step(Term,Res) :- stepBinOp(Term, Res).

step(a(M,N), a(M2,N)) :- step(M,M2).
step(a(M,N), a(M,N2)) :- step(N,N2).

step( a(fun(X,M) , N), Res) :- sub(M,X,N,Res).


step(Xs, Res) :- fromList(Xs, Term), step(Term,Res).

eval(Term, Res) :- step(Term,Term2), eval(Term2,Res),!.
eval(Term, Term).


stepEval(Term,Term).
stepEval(Term, Res) :- step(Term,Term2), stepEval(Term2, Res).


% sub(+Term, +Var, +NewSubterm, -NewTerm)
sub(a(M,N), V, T, a(M2,N2)) :- sub(M,V,T,M2), sub(N,V,T,N2),!.
sub(Xs,     V, T, M2)       :- fromList(Xs,M), sub(M,V,T,M2),!.
sub(fun(X,M), X, _, fun(X,M)) :- !.
sub(fun(X,M), V, T, fun(X,M2)) :- sub(M,V,T,M2),!.
sub(X, X, T, T) :- !.
sub(X,_,_,X) :- !.

3. cvičení

Toto jsme dělali na třetím cvičení (ještě přididám podrobnější komentář..) : 

conc([],Ys,Ys).
conc([X|Xs],Ys,[X|XsYs]) :- conc(Xs,Ys,XsYs).

pridejz(X,Xs,Res) :- conc([X],Xs,Res).
pridejk(X,Xs,Res) :- conc(Xs,[X],Res).

last(Xs,Last) :- conc(_,[Last],Xs).
mem(X,Xs)  :- conc(_,[X|_],Xs).


remove(X,[X|Ys],Ys).
remove(X,[Y|Ys],[Y|Zs]) :- remove(X,Ys,Zs).

insert(X,Xs,Ys) :- remove(X,Ys,Xs).

perm1([],[]).
perm1(Xs,[X|SubPerm]) :- remove(X,Xs,Rest), perm1(Rest,SubPerm).


perm2([],[]).
perm2([X|Xs],Perm) :- perm2(Xs,SubPerm), remove(X,Perm,SubPerm).

%-------------------------------------------------------

rev(Xs,Res) :- rev(Xs,[],Res).
rev([],A,A).
rev([X|Xs], A, Res) :- rev(Xs, [X|A], Res).


%palyndrom(+Xs):


palindrom(X):-rev(X,X).
%containsOnly(?Xs,+Abc).

containsOnly([],_).
containsOnly([X|Xs], Abc) :- containsOnly(Xs, Abc), member(X, Abc).

palyndromFrom(Abc,Xs) :- palindrom(Xs), containsOnly(Xs,Abc).


%-------------------------------------------------------


%zabal(+Xs,-ZXs).
zabal([],[]).
zabal([X|Xs], [[X] | ZXs]) :- zabal(Xs,ZXs).

%pridejHlavy(+Hs,+Ts,-HTs).
pridejHlavy(Hs,[],Ss) :- zabal(Hs,Ss).
pridejHlavy([H|Hs],[T|Ts],[[H|T]|HTs]) :- pridejHlavy(Hs,Ts,HTs).


%transp(+M,-TM).
transp([],[]).
transp([Row|Rows], Res) :- transp(Rows,SubRes), pridejHlavy(Row,SubRes,Res),!.

%sum(+Xs,-Sum)
sum(Xs,Sum) :- sum(Xs,0,Sum).
sum([],A,A).
sum([X|Xs],A,Sum) :- A2 is A + X, sum(Xs,A2,Sum).

% "Xs*Ys = Zs po složkách"
listKrat([],[],[]).
listKrat([X|Xs],[Y|Ys],[Z|Zs]) :- Z is X * Y, listKrat(Xs,Ys,Zs).

listOp(_,[],[],[]).
listOp(Op,[X|Xs],[Y|Ys],[Z|Zs]) :- call(Op,X,Y,Z), listOp(Op,Xs,Ys,Zs).

dotProd(Xs,Ys,Res) :- listKrat(Xs,Ys,Zs), sum(Zs,Res).

listOp1N(_,_,[],[]).
listOp1N(Op,X,[Y|Ys],[Z|Zs]) :-
  call(Op,X,Y,Z),
  listOp1N(Op,X,Ys,Zs).

listOpMN(_,[],_,[]).
listOpMN(Op, [X|Xs], Ys, [R|Rs]) :- listOp1N(Op,X,Ys,R), listOpMN(Op,Xs,Ys,Rs).


mProd(M1, M2, Res) :- transp(M2,TM2), listOpMN(dotProd, M1, TM2, Res).

2. cvičení - Peanova aritmetika & úvod do seznamů

Na druhém cvičení jsme si ukázali jak si lze v prologu zavést "syntaktická" přirozená čísla ve stylu peanovy aritmetiky, jak na nich udělat operace (a to že to jde různými způsoby): 

cislo(o).
cislo(s(X)) :- cislo(X).

plus(o,X,X) :- cislo(X).
plus(s(X),Y,s(Z)) :- plus(X,Y,Z).

minus(Z,X,Y) :- plusko(X,Y,Z).
dvakrat(X,Y) :- plusko(X,X,Y).

krat(o,Y,o) :- cislo(Y).
krat(s(X), Y, Z) :- plus(Y,P,Z), krat(Y,X,P).

pow(Y,o,s(o)) :- cislo(Y).
pow(Y,s(X),Z) :- krat(Y,P,Z), pow(Y,X,P).

mensiNez(o,s(Y)) :- cislo(Y).
mensiNez(s(X),s(Y)) :- mensiNez(X,Y).

mensiNez2(X,s(X)) :- cislo(X).
mensiNez2(X,s(Y)) :- mensiNez2(X,Y).

Za (vedlejší) domácí úkol bylo si rozmyslet použití krat(-X,-Y,+Z), tedy co způsobuje že některé definice fungují a jiné ne.

Dále jsme procvičili několik jednoduchých operací na seznamech. 

prvek(X,[X|_]).
prvek(X,[_|Xs]) :- prvek(X,Xs).

pridejNaZacatek(X, Xs, [X|Xs]).

pridejNaKonec(X, [], [X]).
pridejNaKonec(X, [Y|Ys], [Y|YsX]) :-  pridejNaKonec(X, Ys, YsX).

Za domácí úkol bylo implementova operaci zřetězení dvou seznamů, tak aby fungovala jako: 

zretez(+X,+Y,-Z)

?- zretez([1,2],[3,4,5],X).
X = [1, 2, 3, 4, 5]

ale také jako:

zretez(?X,?Y,+Z)

?- zretez(X,Y,[1,2]).
X = [],
Y = [1,2];
X = [1],
Y = [2];
X = [1,2],
Y = []

1. cvičení - Rodiná pouta

Na prvním cvičení jsme si ukázali základní práci s prologem na příkladu rodiných vztahů.

Za domácí úkol bylo implementova tři netriviální příbuzenské vztahy, zde je příklad jak několik takových vztahů může vypadat pro rodinu Simpsonových: 

% == Databáze elementárních vztahů ========

muz(homer).
muz(bart).
muz(abe).
muz(herb).
muz(clancy).

zena(marge).
zena(lisa).
zena(maggie).
zena(mona).
zena(jackie).
zena(patty).
zena(selma).
zena(ling).

potomek(homer, abe).
potomek(homer, mona).
potomek(bart, homer).
potomek(bart, marge).
potomek(lisa, homer).
potomek(lisa, marge).
potomek(maggie, homer).
potomek(maggie, marge).
potomek(herb, abe).
potomek(herb, mona).
potomek(patty, clancy).
potomek(patty, jackie).
potomek(selma, clancy).
potomek(selma, jackie).
potomek(marge, clancy).
potomek(marge, jackie).
potomek(ling, selma).

manzel(abe, mona).
manzel(homer, marge).
manzel(clancy, jackie).


% == Odvozené vztahy ======================

manzele_sym(X,Y) :- manzel(X,Y);manzel(Y,X).

otec(O,D)  :- potomek(D,O), muz(O).
matka(M,D) :- potomek(D,M), zena(M).

syn(S,R)   :- potomek(S,R), muz(S).
dcera(D,R) :- potomek(D,R), zena(D).

sourozenec(X,Y) :- potomek(X,R), potomek(Y,R), X \= Y.
bratr(X,Y) :- muz(X), sourozenec(X,Y).
sestra(X,Y) :- zena(X),sourozenec(X,Y).

potomek2(X,M,O) :- potomek(X,M), potomek(X,O), zena(M), muz(O).

hardSourozenec(X,Y) :-  potomek2(X,M,O), potomek2(Y,M,O), X\=Y.
hardBratr(X,Y)  :- muz(X),  hardSourozenec(X,Y).
hardSestra(X,Y) :- zena(X), hardSourozenec(X,Y).

vnoucek(X,PraR) :- potomek(X,R), potomek(R,PraR).

teta(X,Y) :- sestra(X,M), potomek(Y,M).

tchan(X,Y) :- manzele_sym(Y,A), otec(X,A).

cousin(X,Y) :- potomek(X,R), sourozenec(R,T), potomek(Y,T).

sestrenice(X,Y) :- zena(X), cousin(X,Y).
bratranec(X,Y) :- muz(X), cousin(X,Y).

snacha(X,Y) :- zena(X), manzele_sym(X,A), potomek(A,Y).
snacha2(X,Y):- syn(A,Y), manzele_sym(X,A).

neter(X,Y)  :- zena(X), potomek(X,R), sourozenec(R,Y).

svagrova(X,Y) :- sestra(X,M), manzele_sym(M,Y).
svagrova(X,Y) :- zena(X), manzele_sym(X,B), bratr(B,Y).




...