Fandom

Education

36JUI Jazyky pro umelou inteligenci

429pages on
this wiki
Add New Page
Talk0 Share

Zkusim sem nejak rozumne napastovat zadani + reseni co se zatim objevily na dostuduj.cz --JaMa 13:19, 23 January 2006 (UTC)


Zadání: Řetězení za sebe seznamů a délek. Edit

Řetězení za sebe seznamů a délek.

(a b c d) --> (a b c d 4 b c d 3 c d 2 d 1 () 0)

LISP:

(defun spocti (sez)
		(append
		(mapcon #'(lambda (X) (append X (list (length X)))) sez)
		'(nil 0))
)

PROLOG:

%spocti([a,b,c,d],N,C).

spocti([],[[],0],0).
spocti([X|Zb], Y, C) :-
    spocti(Zb,Zb1,C1),
    C is C1 + 1,
    append([X|Zb],[C|Zb1], Y).

Zadání: Vypsání podmnožiny podle vektoru. Edit

Vypsání podmnožiny podle vektoru.

('(0 0 1 0 0 1 1) '(a b c d e f g)) --> (c f g)

PROLOG:

sub([], [], []).
sub([X|Zb1], [Y|Zb2], [Y|Out]) :- X=1, sub(Zb1, Zb2, Out).
sub([X|Zb1], [_|Zb2], Out]) :- X=0, sub(Zb1, Zb2, Out).

LISP:

(defun sub (b s)
  (cond ( (null b) nil )
        ( (eq (car b) 0) (sub (cdr b) (cdr s)) )
        ( T (append (list (car s)) (sub (cdr b) (cdr s))) )
) )

Zadání: Potenční množiny. Edit

Potenční množiny.

((a . 1) (b . 2) (b . 3) (c . 4)) --> ( (a b c) (1 2 3 4))

LISP:

(defun pot (s)
  (list (pot1 s) (pot2 s))
)

(defun pot1 (s)
  (cond ( (null s) nil )
        ( T (union (list (caar s)) (pot1 (cdr s))) )
) ) 

(defun pot2 (s)
  (cond ( (null s) nil )
        ( T (union (list (cdar s)) (pot2 (cdr s))) )
) )

PROLOG:

%pot([[a,1],[b,2],[b,3],[c,4]],V).

pot(S, [V1, V2]) :-
    pot1(S, V1),
    pot2(S, V2).

pot1([], []).
pot1([[X,_]|Zb], V1) :-
    pot1(Zb, V1),
    member(X, V1), !.
pot1([[X,_]|Zb], [X|V1]) :-
    pot1(Zb, V1).

pot2([], []).
pot2([[_,Y]|Zb], V2) :-
    pot2(Zb, V2),
    member(Y, V2), !.
pot2([[_,Y]|Zb], [Y|V2]) :-
    pot2(Zb, V2).

Zadání: Zjistit počet opakování vzoru Edit

Zjistit počet opakování vzoru, ale seznam musí být jen z těch vzorů za sebou.

(a b c d a b c d a b c d a b c d ) (a b c d) -> 4
(a b c d a b c d a b c d a b ) (a b c d) -> nil

LISP:

(defun testopak (s v &optional (uv nil) (n 0))
  (cond ( (and (null s) (null uv)) n )
        ( (null uv) (testopak s v v (1+ n)) )
        ( (eq (car s) (car uv)) (testopak (cdr s) v (cdr uv) n) )
        ( NIL)
) )

PROLOG:

%testopak([a,b,c,d,a,b,c,d,a,b,c,d,a,b,c,d],[a,b,c,d],[],N).

testopak([],_,[],0).
testopak(S,V,[],N) :- testopak(S,V,V,N1), N is N1 +1.
testopak([P|S],V,[P|Z],N) :- testopak(S,V,Z,N).

Zadání: Součin relací. Edit

Součin relací.

(soucin '((a.1)(a.2)(b.2)(b.3)) '((1.x)(1.y)(2.z))) --> ((a.x)(a.y)(a.z)(b.z))

LISP:

(defun soucin (r s)
  (cond ( (null r) nil )
        ( T (append (najdi (car r) s) (soucin (cdr r) s)) )
) )

(defun najdi (p s)
  (cond ( (null s) nil )
        ( (eq (cdr p) (caar s)) (cons (cons (car p) (cdar s)) (najdi p (cdr s))) )
        ( T (najdi p (cdr s)) )
)  )

PROLOG:

%soucin([[a,1],[a,2],[b,2],[b,3]], [[1,x],[1,y],[2,z]], V).

soucin([], _, []).
soucin([X|Zb], S, V) :-
    najdi(X, S, B1), !,
    soucin(Zb, S, S1),
    append(B1, S1, V).

najdi(_, [], []).
najdi([A,Y1],[[Y2,B]|ZB], [[A,B]|V]) :- Y1 =:= Y2, !, najdi([A,Y1], ZB, V).
najdi(A, [_|ZB], V) :- najdi(A, ZB, V).

Zadání: Test na prosté zobrazení. Edit

Test na prosté zobrazení.

(proste '((a . 1)(b . 1))) --> nil
(proste '((a . 2)(b . 1))) --> t

LISP:

(defun proste (s &optional (o nil))
  (cond ( (null s) T )
        ( (member (cdar s) o) NIL)
        ( T (proste (cdr s) (cons (cdar s) o)) )
) )

Proste zobrazeni iterace

(defun prIt (Zobr)
    (let ((outs ()))
        (do ((R Zobr (cdr R)))
            ((null R) T)
            (if (member (cdar R) outs)
                (return ())
                (setf outs (cons (cdar R) outs))
            )
;            (prin1 outs) (terpri)
)   ) )

Proste zobrazeni rekurze

(defun prRek (Zobr)
    (if (null Zobr)
        T
        (if (member (cdar Zobr) (mapcan #'(lambda (X) (list (cdr X))) (cdr Zobr)))
            ()
            (prRek (cdr Zobr))
)   ) )

Proste zobrazeni rekurze 2

(defun prRek2 (Zobr)
    (if (null Zobr)
        T
        (if (mapcan #'(lambda (X) (if (eq (cdr X) (cdar Zobr)) '(T) ())) (cdr Zobr))
            ()
            (prRek (cdr Zobr))
)  )  )

Proste zobrazeni hasovaci tabulka

(defun prHash (zobr)
    (let (ht)
        (setf ht (make-hash-table))
        (do ((R zobr (cdr R)))
            ((null R) T)
            (if (gethash (cdar R) ht)
                (return ())
                (setf (gethash (cdar R) ht) T)
)   )  ) )

PROLOG:

%proste([[a,1],[b,2]]).

porovnej([X1, Y1], [X2, Y2]) :-
    X1 \= X2,
    Y1 \= Y2.
porovnej([X1 ,Y1], [X2, Y2]) :-
    X1 = X2,
    Y1 = Y2.

zkontroluj(_, []).
zkontroluj(X, [Y|Zb]) :-
    porovnej(X, Y), !,
    zkontroluj(X, Zb).

proste([]).
proste([X|Zb]) :-
    zkontroluj(X, Zb), !,
    proste(Zb).

Zadání: pocet neprekryvajicich se vyskytu posloupnosti P v posloupnosti Q Edit

P,Q jsou posloupnosti vyjadrene seznamem prvku. P je neprazdna. Navrhnete fci PocetOpak(P ,Q) ktera urci pocet neprekryvajicich se vyskytu posloupnosti P v posloupnosti Q.

(pocetopak '(a b a b) '(a b a b a b a c a b a b c d)) --> 2

LISP:

(defun pocetopak (p q)
  (popak p q p 0)
)

(defun popak (p q up n)
  (cond ( (null up) (popak p q p (1+ n)) )
        ( (null q) n )
        ( (eq (car up) (car q)) (popak p (cdr q) (cdr up) n) )
        ( T (popak p (cdr q) p n)) 
)  )
(defun fp (pat text)
    (fPat pat pat text 0)
)

(defun fPat (pat rpat rtext cnt)
    (cond   ((and (null rpat) (null rtext)) (1+ cnt))
            ((null rtext) cnt)
            ((null rpat) (fPat pat pat rtext (1+ cnt)))
            ((eql (car rpat) (car rtext)) (fPat pat (cdr rpat) (cdr rtext) cnt))
            (T (fPat pat pat (cdr rtext) cnt))
    )
)

PROLOG:

%pocetopak([a,b,a,c], [a,b,a,b,a,b,a,c,a,b,a,b,c,d], N).

pocetopak(P, S, N) :- popak(P, S, P, N), !.
popak(_, [], _, 0).
popak(P, Q, [], N) :-
    popak(P, Q, P, N1),
    N is N1 +1.
popak(P, [X|Zb], [X|Z], N) :- popak(P, Zb, Z, N).
popak(P, [_|Z], Y, N) :- popak(P, Z, Y, N).

Zadání: Zda v Q existuje N neprekryvajicich se vyskytu posloupnosti P Edit

P,Q - posloupnosti vyjadrene jako seznam prvku, P je neprazdna. Navrhnete funkci, ktera urci, zda v Q existuje N neprekryvajicich se vyskytu posloupnosti P.

LISP:

(defun testpocetopak (p q n)
  (eq (pocetopak p q) n)	; viz. vyse
)

PROLOG:

testpocetopak(P,Q,N) :- pocetopak(P, Q, N), N = N1.

Zadání: Zda dana posloupnost je orientovanym tahem Edit

P je seznam tecka dvojic (u . v) vyjadrujicich posloupnost orientovanych hran grafu. Navrhnete fci ktera testuje, zda dana posloupnost je orientovanym tahem (souvisle bez opakovani hran).

(testtah '((a . b)(b . c)(c . b)(b . d))) --> t
(testtah '((a . b)(b . c)(c . a)(a . d)(d . b)(b . c))) --> nil

LISP:

(defun testtah (s)
  (testuj (car s) (cdr s) nil)
)

(defun testuj (p s h) 		; polozka (jedna hrana), cesta, pouzite hrany
  (cond ( (member p h :test #'equal) NIL )
        ( (null s) T )
        ( (eq (cdr p) (caar s)) (testuj (car s) (cdr s) (cons p h)) )
) )

Zadání: Reprezentaci grafu seznamem sousedu Edit

Je seznam orientovanych hran grafu (u . v). Fce ma pro dany seznam udelat reprezentaci grafu seznamem sousedu.

((a b) (a c) (b d) (d c) (b c)) --> ((a b c) (b d c) (d c))

LISP:

(defun sousedi (s)
  (cond ( (null s) nil )
        ( T (append (list (cons (caar s) (vyber (caar s) s))) (sousedi (odstran (caar s) s)) ) )
) )

(defun vyber (p s)
  (cond ( (null s) nil )
        ( (eq p (caar s)) (cons (cdar s) (vyber p (cdr s)) ) )
        ( T (vyber p (cdr s) ) )
) )

(defun odstran (p s)
  (cond ( (null s) nil )
        ( (eq p (caar s)) (odstran p (cdr s)) )
        (T (cons (car s) (odstran p (cdr s)) ) )
) )

LISP2: Prevod seznamu hram na seznamy následníku

(defun sousedi (S acc)
    (cond   ((null S) acc)
            (T
                (let ((as (assoc (caar S) acc)))
                    (if (null as)
                        (sousedi (cdr S) (cons (list (caar S) (cadar S)) acc))
                        (sousedi (cdr S)  (cons (append as (list (cadar S))) (remove as acc)))
)   )      )   ) )

Zadání: Nejopakovanejsi pismeno Edit

Fce ma vratit (x . pocet), kde x je pismeno, ktere se v textu nejvicekrat opakuje za sebou a pocet je pocet opakovani.

(a b c d d e )  --> (d . 2)

LISP:

	
(defun nejopak (s)
  (nejopak2 (car s) (cdr s) (cons (car s) 1) 1)
)

(defun nejopak2 (p s max n)
  (cond ( (null s) 
        (cond ( (> n (cdr max)) (cons p n) ) 
                ( max )
               )
        )
       ( (eq p (car s)) (nejopak2 p (cdr s) max (1+ n)) )
       ( (> n (cdr max)) (nejopak2 (car s) (cdr s) (cons p n) 1) )
       ( T (nejopak2 (car s) (cdr s) max 1) )
) )

PROLOG:

%nejopak([a,b,c,f,f,f,f],N).

nejopak([A|Zb], V) :-
    nejopak2(A, Zb, [A,1], 1, V), !.

nejopak2(_, [], [Vp,Vn], N, [Vp,Vn]) :- Vn >= N.
nejopak2(P, [], [_,Vn], N, [P,N]) :- Vn < N.
nejopak2(P, [P|S], M, N, V) :- N1 is N + 1, nejopak2(P, S, M, N1, V).
nejopak2(P, [D|S], [_,Vn], N, V) :- N > Vn, !, nejopak2(D, S, [P,N], 1, V).
nejopak2(_, [D|S], M, _, V) :- nejopak2(D, S, M, 1, V).

Zadání: Body v primce? Edit

Seznam bodu (x . y), alespon 2 body. Zjistete, zda dane body lezi v 1 primce.

(primka '((1 . 1) (2 . 2) (3 . 3))) --> t
(primka '((1 . 1) (2 . 2) (3 . 4))) --> nil

LISP:

(defun primka (s)
  (primka2 (smernice (car s) (cadr s)) (cadr s) (cddr s)) 
)

(defun primka2 (k a s) ; smernice, bod, zbytek pole
  (cond ( (null s) T )
        ( (eq k (smernice a (car s))) (primka2 k (car s) (cdr s)) )
) )

(defun smernice (a b)
  (cond ( (= (car a) (car b)) NIL )
        ( T (abs (/ (- (cdr a) (cdr b)) (- (car a) (car b)))) )
)  )

PROLOG:

%primka([[1,1],[2,2],[5,5]]).

primka([A,B|Z]) :-
    smernice(A, B, S),
    primka2(S, B, Z),!.

primka2(_, _, []).
primka2(S,A,[B|Z]) :-
    smernice(A, B, S),
    primka2(S, B, Z).

smernice([X1,Y1], [X2,Y2], S) :-
    S is (X1 - X2) / (Y1 - Y2).

Zadání: Test rostouci fce Edit

Je dan seznam (x . F(x)). Udelejte fci, ktera overi, ze dany seznam je rostouci funkce.

LISP:

(defun rostouci (s)
  (cond ( (null s) T )
        ( (testrost (car s) (cdr s)) (rostouci (cdr s)) )
) )

(defun testrost (f s)
  (cond ( (null s) T )
        ( (and (> (car f) (caar s)) (> (cdr f) (cdar s))) (testrost f (cdr s)) )
        ( (and (< (car f) (caar s)) (< (cdr f) (cdar s))) (testrost f (cdr s)) )
        ( (equal f (car s)) (testrost f (cdr s)) )
)  )

PROLOG:

%rostouci([[1,1],[2,5],[3,6]]).

testrost(_, []).
testrost([X1,Y1], [[X2,Y2]|Zb]) :-
    X1 > X2, !,
    Y1 > Y2,
    testrost([X1,Y1], Zb).
testrost([X1,Y1], [[X2,Y2]|Zb]) :-
    X1 < X2, !,
    Y1 < Y2,
    testrost([X1,Y1], Zb).

rostouci([]).
rostouci([X|Zb]) :-
    testrost(X, Zb), !,
    rostouci(Zb).

Zadání: Test otevrene orientovane cesty Edit

Mame posloupnost hran o. g. zadanou jako seznam po sobe jdoucich hran. Mame zjistit, zda ta posloupnost hran tvori otevrenou orientovanou cestu (neopakuji se uzly).

(testcesta '((a.b) (b.c) (c.d))) --> t

LISP:

(defun testcesta (s)
  (testujcestu (car s) (cdr s) (list (caar s)))
)

(defun testujcestu (p s u) 		; polozka (jedna hrana), seznam, pouzite uzly
  (cond ( (member (cdr p) u) NIL )
        ( (null s) T )
        ( (eq (cdr p) (caar s)) (testujcestu (car s) (cdr s) (cons (car p) u)) )
)  )

Zadání: Histogram Edit

Histogram.

	(histogram 2 4 5 3 1) -->

			X
		X	X
		X	X	X
	X	X	X	X
	X	X	X	X	X
	--------------------------------------

LISP:

(defun histogram (&rest s)
  (histlist s)
  (pomlcky (1- (* 2 (length s))))
)

(defun histlist (s)
  (cond ( (testnuly s) nil )
        ( T (histlist (mapcar #'1- s)) (vypis s) )
)  )

(defun pomlcky (n)
  (cond ( (eq n 0) (terpri) )
        ( T (princ "-") (pomlcky (1- n)) )
)  )

(defun testnuly (s)
  (cond ( (null s) T )
        ( (<= (car s) 0) (testnuly (cdr s)) )
) )

(defun vypis (s)
  (cond ( (null s) (terpri) )
        ( (> (car s) 0) (princ "X ") (vypis (cdr s)) )
        ( T (princ "  ") (vypis (cdr s)) )
)  )

LISP2:

(defun hist (&rest S)
    (let ((mx (maxS S)))
        (loop
            (if (= 0 mx) (return ()))
            (do ((R S (cdr R)))
                ((null R) T)
                (if (<= mx (car R)) (format T "X " )(format T "  " ))
            )
            (terpri)
            (setf mx (1- mx))
        )
    )
    (dotimes (i (length S) T) (format T "--"))
    (terpri)
)

Zadání: Sachovnice Edit

Sachovnice

(defun swap-area (Area)
    (let ((x1 0) (y1 0) (x2 0) (y2 0))
        (setf x1 (nth 0 Area))
        (setf y1 (nth 1 Area))
        (setf x2 (nth 2 Area))
        (setf y2 (nth 3 Area))
        (if (> x1 x2)
            (list x2 y1 x1 y2)
            (list x1 y1 x2 y2)
)   )  )

(defun get-x1 (S)  (nth 0 S) )

(defun get-y1 (S) (nth 1 S))

(defun get-x2 (S) (nth 2 S) )

(defun get-y2 (S) (nth 3 S) )

(defun point-in (x y S)
    (if (and (>= x (get-x1 S)) (<= x (get-x2 S)) (>= y (get-y1 S)) (<= y (get-y2 S)))
        T ()
)   )

(defun TestD (S1 S2)
    (setf S1 (swap-area S1))
    (setf S2 (swap-area S2))
    (if (or (point-in (get-x1 S1) (get-y1 S1) S2)
            (point-in (get-x2 S1) (get-y1 S1) S2)
            (point-in (get-x1 S1) (get-y2 S1) S2)
            (point-in (get-x2 S1) (get-y2 S1) S2)
            (point-in (get-x1 S2) (get-y1 S2) S1)
            (point-in (get-x2 S2) (get-y1 S2) S1)
            (point-in (get-x1 S2) (get-y2 S2) S1)
            (point-in (get-x2 S2) (get-y2 S2) S1)
        )
        () T)
)

(defun my-min (x y)
    (if (< x y)
        x
        y
)  )

(defun my-max (x y)
    (if (> x y)
        x
        y
)   )

(defun TestIn (S1 S2)
    (setf S1 (swap-area S1))
    (setf S2 (swap-area S2))
    (list (my-min (get-x1 S1)(get-x1 S2))
          (my-min (get-y1 S1)(get-y1 S2))
          (my-max (get-x2 S1)(get-x2 S2))
          (my-max (get-y2 S1)(get-y2 S2))
)  )

(defun TestP (S1 S2)
    (setf S1 (swap-area S1))
    (setf S2 (swap-area S2))
    (list (my-max (get-x1 S1)(get-x1 S2))
          (my-max (get-y1 S1)(get-y1 S2))
          (my-min (get-x2 S1)(get-x2 S2))
          (my-min (get-y2 S1)(get-y2 S2))
)  )

(defun point-in-any (x y Areas)
    (cond ((null Areas) ())
          ((point-in x y (car Areas)) T)
          (T (point-in-any x y (cdr Areas)))
)  )

(let ((preds ()))
    (defun init-preds () (setf preds ()))
    (defun set-preds (S n)
;        (prin1 S) (terpri)
        (cond ((null S) ())
              (T (setf preds (append (cons (list (car S) n) (set-preds (cdr S) n)) preds)))
        )
    )
    (defun get-preds () preds)

    (defun get-pred (n)
        (dolist (el preds ())
            (if (eql (car el) n) (return (cadr el)))
        )
    )

    (defun extract-path (n)
        (cond ((null n) ())
              (T (append (extract-path (get-pred n)) (list n)))
        )
    )
)

(let ((Areas ()) (n 0) (x 0) (y 0) (tmp ()))
    (defun set-dim (NN) (setf n NN))
    (defun get-dim () n)
    (defun set-areas (A) (setf Areas a))
    (defun get-adj (P)
        (setf x (car P))
        (setf y (cadr P))
        (setf tmp ())
;        (prin1 x) (prin1 y) (terpri)
;        (prin1 n) (terpri)
        (if (and (>= (1- x) 1) (not (point-in-any (1- x) y Areas))) (setf tmp(cons (list (1- x) y) tmp)))
        (if (and (<= (1+ x) n) (not (point-in-any (1+ x) y Areas))) (setf tmp(cons (list (1+ x) y) tmp)))
        (if (and (>= (1- y) 1) (not (point-in-any x (1- y) Areas))) (setf tmp(cons (list x (1- y)) tmp)))
        (if (and (<= (1+ y) n) (not (point-in-any x (1+ y) Areas))) (setf tmp(cons (list x (1+ y)) tmp)))
        tmp
    )
    (defun get-areas () Areas)
    (defun point-in-areas (n) (point-in-any (car n) (cadr n) Areas))
)

(defun my-remove (e l)
;    (prin1 e) (prin1 l) (terpri)
    (cond ((null l) ())
          ((not (equal e (car l))) (cons (car l) (my-remove e (cdr l))))
          (T (my-remove e (cdr l)))
)  )

(defun list-difference (l1 l2)
;    (terpri)
;    (prin1 l1) (prin1 l2) (terpri)
    (dolist (e l2 l1) (setf l1 (my-remove e l1)))
)

(defun BFS (start-node goal-node)
    (let ((opened (list start-node)) (closed ()) n ls)
        (if (or (point-in-areas  start-node)(point-in-areas goal-node))
            'failurefirst
            (progn
                (init-preds)
                (set-preds (list start-node) ())
;                (prin1 (get-preds))(terpri)
;                (prin1 opened)(terpri)
                (loop
                    (if (null opened) (return 'failuresecond))
                    (setf n (pop opened))
                    (push n closed)
                    (if (equal goal-node n) (return (extract-path n)))
                    (setf ls (get-adj n))
                    (setf ls (list-difference ls (append opened closed)))
;                    (prin1 opened) (terpri)
;                    (prin1 closed) (terpri)
;                    (prin1 ls) (terpri)(terpri)
                    (setf opened (append opened ls))
                    (set-preds ls n)
;                    (if (> (length ls) 1) (return ()))
)   )  )   )  )

(defun generate (d n)
    (if (> d n)
        ()
        (cons d (generate (1+ d) n))
)  )

(defun rows (rws ars)
    (if (null ars)
        rws
        (let ((ar 0))
            (setf ar (swap-area (car ars)))
            (setf rws (list-difference rws (generate (get-y1 ar) (get-y2 ar))))
            (rows rws (cdr ars))
)   ) )

(defun cols (cls ars)
    (if (null ars)
        cls
        (let ((ar 0))
            (setf ar (swap-area (car ars)))
            (setf cls (list-difference cls (generate (get-x1 ar) (get-x2 ar))))
            (cols cls (cdr ars))
)   ) )

(defun testproc ()
    (set-dim 10)
    (set-areas '((1 2 5 5))); (2 7 6 9) (7 1 10 9)))
    (prin1 (BFS '(1 1) '(10 10))) (terpri)
    (prin1 (rows (generate 1 (get-dim)) (get-areas))) (terpri)
    (cols (generate 1 (get-dim)) (get-areas))
)

PROLOG:

swap([X1, Y1, X2, Y2], [X2, Y2, X1, Y1]):- X1 > X2, Y1 > Y2.
swap([X1, Y1, X2, Y2], [X2, Y1, X1, Y2]):- X1 > X2, Y1 =< Y2.
swap([X1, Y1, X2, Y2], [X1, Y2, X2, Y1]):- X1 =< X2, Y1 > Y2.
swap([X1, Y1, X2, Y2], [X1, Y1, X2, Y2]):- X1 =< X2, Y1 =< Y2.

getX1([X1, Y1, X2, Y2], X1).
getY1([X1, Y1, X2, Y2], Y1).
getX2([X1, Y1, X2, Y2], X2).
getY2([X1, Y1, X2, Y2], Y2).

isIn([X, Y],[QX1, QY1, QX2, QY2]):-swap([QX1, QY1, QX2, QY2], [X1, Y1, X2, Y2]),X=<X2, X>=X1, Y=<Y2, Y>=Y1.
isInX(X,[QX1, QY1, QX2, QY2]):-swap([QX1, QY1, QX2, QY2], [X1, Y1, X2, Y2]),X=<X2, X>=X1.
isInY(Y,[QX1, QY1, QX2, QY2]):-swap([QX1, QY1, QX2, QY2], [X1, Y1, X2, Y2]),Y=<Y2, Y>=Y1.

testNotD(A,B):-
    swap(A,AS), swap(B,BS),
    (getX1(AS,X), getY1(AS, Y), isIn([X,Y], BS);
     getX2(AS,X), getY1(AS, Y), isIn([X,Y], BS);
     getX1(AS,X), getY2(AS, Y), isIn([X,Y], BS);
     getX2(AS,X), getY2(AS, Y), isIn([X,Y], BS);
     getX1(BS,X), getY1(BS, Y), isIn([X,Y], AS);
     getX2(BS,X), getY1(BS, Y), isIn([X,Y], AS);
     getX1(BS,X), getY2(BS, Y), isIn([X,Y], AS);
     getX2(BS,X), getY2(BS, Y), isIn([X,Y], AS)).

testD(A, B):- not(testNotD(A,B)).

min(X, Y, X):- X<Y.
min(X, Y, Y):- X>=Y.

max(X, Y, X):- X>Y.
max(X, Y, Y):- X=<Y.

testIn(A,B, [X1,Y1,X2,Y2]):-
    swap(A,AS), swap(B,BS),
    getX1(AS, AX), getX1(BS, BX), min(AX,BX,X1),
    getY1(AS, CX), getY1(BS, DX), min(CX,DX,Y1),
    getX2(AS, EX), getX2(BS, FX), max(EX,FX,X2),
    getY2(AS, GX), getY2(BS, HX), max(GX,HX,Y2).

testP(A,B, [X1,Y1,X2,Y2]):-
    swap(A,AS), swap(B,BS),
    getX1(AS, AX), getX1(BS, BX), max(AX,BX,X1),
    getY1(AS, CX), getY1(BS, DX), max(CX,DX,Y1),
    getX2(AS, EX), getX2(BS, FX), min(EX,FX,X2),
    getY2(AS, GX), getY2(BS, HX), min(GX,HX,Y2),
    min(X1,X2,X1),
    min(Y1,Y2,Y1).
    
isInS(B, [A|S]):-isIn(B,A),!.
isInS(B, [A|S]):-isInS(B,S).

isInSX(B, [A|S]):-isInX(B,A),!.
isInSX(B, [A|S]):-isInSX(B,S).

isInSY(B, [A|S]):-isInY(B,A),!.
isInSY(B, [A|S]):-isInSY(B,S).


setDim(N):-assert(dim(N)).
resetDim(N):-retract(dim(_)),assert(dim(N)).
deleteDim():-retract(dim(_)).

muzu([X,Y]):-
    o(S),
    not(isInS([X,Y], S)),
    X > 0, Y > 0, d(N), X =< N, Y =< N.

enqueue([X,Y]):- not(clause(fronta(X,Y),_)), assertz(fronta(X,Y)).
enqueue([X,Y]):- not(fronta(X,Y)), assertz(fronta(X,Y)).

dequeue([X, Y]):-not(clause(fronta(X,Y),_)),!,fail.
dequeue([X, Y]):-retract(fronta(X,Y)).

generuj([X,Y],[Q,Y],Cesta):-
    o(S),
    Q is X+1,
    not(member([Q,Y], Cesta)),
    muzu([Q,Y]).
generuj([X,Y],[Q,Y],Cesta):-
    o(S),
    Q is X-1,
    not(member([Q,Y], Cesta)),
    muzu([Q,Y]).
generuj([X,Y],[X,Q],Cesta):-
    o(S),
    Q is Y+1,
    not(member([X,Q], Cesta)),
    muzu([X,Q]).
generuj([X,Y],[X,Q],Cesta):-
    o(S),
    Q is Y-1,
    not(member([X,Q], Cesta)),
    muzu([X,Q]).


d(10).
o([[3,3,3,3],[2,3,4,6],[10,10,10,10]]).


cesta(Start, Cil, Oblasti, Dimenze, Vysledek):-
    assert(d(Dimenze)),
    assert(o(Oblasti)),
    kill(o),
    kill(d),
    assert(d(Dimenze)),
    assert(o(Oblasti)),
%    write('Jsem v Cesta'), nl,
    bfs([[Start]], Cil, VysledekR),
    reverse(VysledekR, Vysledek),
    !,
    kill(o),
    kill(d).

bfs([[Cil|Zb]|_], Cil, [Cil|Zb]).
bfs([Cesta|Fronta],Cil, Vysl):-
    prodluz(Cesta, NCesty),
    pridej(Fronta, NCesty, NFronta),
    bfs(NFronta, Cil, Vysl).


pridej(Fronta, Cesty, NFronta):-
    reverse(Fronta, PomF),
    pridejpom(PomF, Cesty, NFronta).

reverse(Fronta, PomF):-
    revpom(Fronta, [], PomF).

revpom([],Vysl, Vysl).
revpom([X|Zb], Acc, Vysl):-
    revpom(Zb, [X|Acc], Vysl).

pridejpom([], Cesty, Cesty).
pridejpom([Cesta|Zb], Cesty, Vysl):-
    pridejpom(Zb, [Cesta|Cesty], Vysl).

prodluz([Bod|Zbytek], NCesty):-
    findall([Soused, Bod | Zbytek], generuj(Bod, Soused, [Bod|Zbytek]), NCesty),
%    write([Bod|Zbytek]),nl,nl,
%    write(NCesty),nl,nl,
    !.
prodluz(Cesta,[]).


cols(Out):-
    o(S),
    cols2(1,S,Out).

cols2(X, _, []):-d(Dim),X>Dim,!.
cols2(X, S, Out):-
    isInSX(X,S),!,
    Y is X+1,
    cols2(Y, S, Out).
cols2(X, S, [X|Out]):-
    Y is X+1,
    cols2(Y, S, Out).

rows(Out):-
    o(S),
    rows2(1,S,Out).

rows2(Y, _, []):-d(Dim),Y>Dim,!.
rows2(Y, S, Out):-
    isInSY(Y,S),!,
    X is Y+1,
    rows2(X, S, Out).
rows2(Y, S, [Y|Out]):-
    X is Y+1,
    rows2(X, S, Out).

Zadání: Booleovske vyrazy Edit

Booleovske vyrazy

(defun Test (BV)
    (cond ((null BV) ())
          ((numberp BV) (or (= BV 1) (= BV 0)))
          ((atom BV) T)
          ((eq (car BV) 'not) (if (= (length BV) 2)
                                 (Test (cadr BV))
                                 ()
                             )
          )
          ((eq (car BV) 'and) (eval (cons 'and (mapcar #'Test (cdr BV)))))
          ((eq (car BV) 'or) (eval (cons 'and (mapcar #'Test (cdr BV)))))
          (T ())
)  )

(defun Var (BV)
    (cond ((null BV) ())
          ((numberp BV) ())
          ((atom BV) (list BV))
          ((eq (car BV) 'not) (if (= (length BV) 2)
                                 (Var (cadr BV))
                                 ()
                             )
          )
          ((eq (car BV) 'and) (mapcan #'Var (cdr BV)))
          ((eq (car BV) 'or) (mapcan #'Var (cdr BV)))
          (T ())
)  )

(defun find-val (V A)
    (cond ((null A) 0)
          ((equal  (caar A) V) (cdar A))
          (T (find-val V (cdr A)))
)  )

(defun Evl (BV A)
    (cond ((null BV) 0)
          ((numberp BV) BV)
          ((atom BV) (find-val BV A))
          ((eq (car BV) 'not) (if (= (length BV) 2)
                                 (if (= (Evl (cadr BV) A) 1) 0 1)
                                 0
                             )
          )
          ((eq (car BV) 'and) (if (member 0 (mapcar #'(lambda (X) (Evl X A)) (cdr BV))) 0 1))
          ((eq (car BV) 'or) (if (member 1 (mapcar #'(lambda (X) (Evl X A)) (cdr BV))) 1 0))
          (T 0)
)  )

(defun Taut (BV)
    (cond
          ((numberp BV) (if (= BV 1) T ()))
          ((atom BV) 'prom )
          ((eq (car BV) 'not)
                                 (cond ((eq (Taut (cadr BV)) 'prom) 'prom)
                                       ((eq (Taut (cadr BV)) T) ())
                                       (T T)
                                 )
          )
          ((eq (car BV) 'and) (cond
                    ((member () (mapcar #'Taut (cdr BV))) ())
                    ((member 'prom (mapcar #'Taut (cdr BV))) 'prom)
                    (T T)
          ))
          ((eq (car BV) 'or) (cond
                    ((member T (mapcar #'Taut (cdr BV))) T)
                    ((member 'prom (mapcar #'Taut (cdr BV))) 'prom)
                    (T ())
          ))
          (T ())
)  )

PROLOG:

%Test(BV). --> yes/no.

testSez([]).
testSez(X,  S):-
    !,
    test(X),
    testSez(S).

test(0).
test(1).
test(X):-
    var(X).
%Test([not, X]):- tak tady nevim, jak dal...

Zadání: Domino Edit

Domino

(defun add-domino (A S)
    (if (null A)
        (progn
            (prin1 S)(terpri)
            T
        )
        (let ((pred ()) (za A) (elm ()) (lst (car (last S))))
            (loop
                (if (null za) (return ()))
                (setf elm (car za))
                (setf za (cdr za))
;                (prin1 lst) (prin1 elm) (terpri)
                (if (eq (cdr lst) (car elm))
                    (progn
;                        (format T "Add-domino - Append: ~S List: ~S ~%" (append pred za) (append S (list elm)))
                        (if (add-domino (append pred za) (append S (list elm))) (return T))
                    )
                )
                (setf pred (cons elm pred))
)   )  ) )

(defun domino (A)
    (let ((pred ()) (za A) (elm ()))
        (loop
            (if (null za) (return ()))
            (setf elm (car za))
            (setf za (cdr za))
;            (format T "Domino - Append: ~S List: ~S ~%" (append pred za) (list elm))
            (if (add-domino (append pred za) (list elm)) (return T))
            (setf pred (cons elm pred))
)   ) )

PROLOG:

%domino([a,b], [b,c],[c,d]).


vyber([A|S], A, S).
vyber([A|S], N, [A|O]):-
    vyber(S, N, O).


domino(S):-
    vyber(S, [X,Y], O),
    dom2(O, Y).

dom2([], _).
dom2(S, X):-
    vyber(S, [X,Y],O),
    dom2(O, Y).

Zadání: Prelozeni posloupnosti Edit

Prelozeni posloupnosti

(defun p-rec (S1 S2 DB)
;    (format T "DB v p-rec: ~S ~%" DB)
    (cond ((and (null S1) (null S2)) T)
          ((or (null S1) (null S2)) ())
          (T
            (let ((pairval ()))
                (setf pairval (find-pair (car S1) DB))
;                (format T "pairval v p-rec: ~S <==> ~S (car S2): ~S ~%" (car S1) pairval (car S2))
                (if (null pairval)
                    (progn
                        (setf DB (cons (cons (car S1) (car S2)) DB))
                        (p-rec (cdr S1) (cdr S2) DB)
                    )
                    (if (eq (car S2) pairval)
                        (p-rec (cdr S1) (cdr S2) DB)
                        ()
)   )     ))   ))

(defun p (S1 S2)
    ;;;;??????????????????
    (and (p-rec S1 S2 ()) (p-rec S2 S1 ()))
)

(defun find-pair (V DB)
    (cond ((null DB) ())
          ((equal  (caar DB) V) (cdar DB))
          (T (find-pair V (cdr DB)))
)  )

Zadání: Odpovidajici si seznamy Edit

Odpovidajici si seznamy

(defun odpovida (S1 S2)
    (cond   ((and (null S1) (null S2)) T)
            ((or (null S1) (null S2)) ())
            ((numberp (car S1))
             (if    (= (car S1) (car S2))
                    (odpovida (cdr S1) (cdr S2))
                    ()
             ))
            ((atom (car S1)) (odpovida (cdr S1) (cdr S2)))
            ((listp (car S1))
             (if (listp (car S2))
               (and (odpovida (car S1) (car S2)) (odpovida (cdr S1) (cdr S2)))
               ()
             ))
            (T ())
)  )






Zadání: Nalezeni orientovaneho tahu Edit

Nalezeni orientovaneho tahu  ??? nejake divne

(defun testtah (hrany)

)

(defun maxS (S)
    (do ((R S (cdr R)) (mx 0 mx))
        ((null R) mx)
        (if (> (car R) mx) (setf mx (car R)))
)  )


Zadání: Vektory Edit

Vektory

(defun vect(U V)
    (mapcan #'(lambda (X Y) (if (= X 1) (list Y) ())) U V)
)

Zadání: Transitivni relace Edit

Transitivni relace

(defun myMember (e L)
    (cond   ((null L) ())
            ((equal e (car L)) T)
            (T (myMember e (cdr L)))
)  )

(defun trans(S)
    (let ((cur ()) (nxt ()))
        (do ((R S (cdr R)))
            ((null R) T)
            (setf cur (car R))
            (if
                (do ((Q S (cdr Q)))
                    ((null Q) T)
                    (if (eql (cdr cur) (caar Q))
                        (if (not (myMember (cons (car cur) (cdar Q)) S)) (return ()))
                        T
                    )

                )
                T
                (return ())
)   )  ) )

Zadání: Otevrena neprazdna cesta Edit

Otevrena neprazdna cesta

(defun je-cesta (uzite hrany)
    (cond   ((null hrany) T)
            (T
                (if (member (cdar hrany) uzite)
                    ()
                    (je-cesta (cons (cdar hrany) uzite) (cdr hrany))
)   )      )   )

(defun cesta (H)
    (if (null H)
        H
        (je-cesta (list (caar H)) H)
    )
)

Zadání: Ekvivalence se substitucemi Edit

Ekvivalence se substitucemi

(defun pom-ekviv (out U V)
    (cond   ((and (null U) (null V)) out)
            ((or (null U) (null V)) ())
            (T
                (let ((as (assoc (car U) out)))
                    (cond ((null as)
                            (pom-ekviv (cons (cons (car U) (car V)) out) (cdr U) (cdr V))
                          )
                          ((eq (cdr as) (car V))
                            (pom-ekviv out (cdr U) (cdr V))
                          )
                          (T ())
)  )       )   )   )   

(defun ekviv (U V)
    (let ((a (pom-ekviv () U V)) (b (pom-ekviv () V U)))
        (if (or (null a) (null b)) () a)
)  )

Zadání: Reprezentace stromu Edit

Reprezentace stromu

(defun vloz-uroven (n R S)
    (cond   ((= 0 n) (rplaca R S))
            (T (vloz-uroven (1- n) (cdr R) S))
)  )

 (defun vloz (P R S)
    (cond   ((null R) (write-line "CHYBA"))
            ((null (cdr P)) (vloz-uroven (car P) R S))
            (T
                (vloz (cdr P) (nth (car P) R) S)
)   )     )

(defun maxval(S)
    (do ((R S (cdr R)) (m 0 m))
        ((null R) m)
        (if (> (car R) m ) (setf m (car R)))
)  )

(defun hloubka (S)
    (cond   ((null (cdr S)) 0)
            (T
                (1+ (maxval (mapcar #'hloubka (cdr S))))
)   )     )

(defun maxst (S)
    (cond   ((null (cdr S)) 0)
            (T
               (max (1- (length S)) (maxval (mapcar #'maxst (cdr S))))
)   )     )

(defun poselm (P R)
    (cond   ((null R) (write-line "CHYBA"))
            ((null (cdr P)) (nth (car P) R ))
            (T
                (poselm (cdr P) (nth (car P) R))
)   )     )

Zadání: Reflexivita relace Edit

Reflexivita relace

(defun myMember (e L)
    (cond   ((null L) ())
            ((equal e (car L)) T)
            (T (myMember e (cdr L)))
)  )

(defun reflex (W)
    (let ((ref ()) (l ()) (r ()) )
        (do ((Q W (cdr Q)))
            ((null Q) ())
            (setf l (caar Q))
            (setf r (cdar Q))
;            (prin1 l)(prin1 r)(terpri)
            (if (not (assoc l ref)) (setf ref (cons (cons l l) ref)))
            (if (not (assoc r ref)) (setf ref (cons (cons r r) ref)))
        )
;        (prin1 ref)(terpri)
        (do ((Q ref (cdr Q)))
            ((null Q) T)
            (if (not (myMember (car Q) W)) (return ()))
)   ) )

PROLOG:

reflex(S):-
    reflex2(S, S).

reflex2([],_).
reflex2([[X|X]|S],Q):-
    reflex2(S,Q),!.
reflex2([[X|Y]|S],Q):-
    member([X|X], Q),
    member([Y|Y], Q),
    reflex2(S, Q).

Zadání: Powerset mnoziny Edit

Powerset mnoziny

(defun powerset (S)
    (cond   ((null S) (list ()))
            (T
                (let ((pom (powerset (cdr S))))
                    (append (mapcar #'(lambda (X) (cons (car s) X)) pom) pom )
)   )      ) )

PROLOG:

powerset([],[[]]).
powerset([A|S], Out):-
    powerset(S, Out2),
    pridej(A, Out2, Out3),
    append(Out2, Out3, Out).

pridej(_,[],[]).
pridej(A, [B|S], [[A|B]|Out]):-
    pridej(A, S, Out).

Zadání: Obory hodnot Edit

Obory hodnot

(defun oboryr (R LevyOb PravyOb)
    (if (null R)
        (list LevyOb PravyOb)
        (oboryr (cdr R) (adjoin (caar R) LevyOb)(adjoin (cdar R) PravyOb))
)  )

(defun obory (R)
    (oboryr R () ())
)

Zadání: Periody Edit

Periody

(defun period (Q P)
    (fPat P P Q 0)
)

(defun fPat (pat rpat rtext cnt)
;    (prin1 rpat)(prin1 rtext)(terpri)
    (cond   ((and (null rpat) (null rtext)) (1+ cnt))
            ((null rtext) ())
            ((null rpat) (fPat pat pat rtext (1+ cnt)))
            ((eql (car rpat) (car rtext)) (fPat pat (cdr rpat) (cdr rtext) cnt))
            (T ())
)  )

Zadání: Cdry seznamu Edit

Cdry seznamu

(defun makeit (S)
    (append (mapcon #'(lambda (X) (append X (list (length X))))  S) (list () 0))
)

Zadání: Moje sjednoceni Edit

Moje sjednoceni

(defun MyUnion (S1 S2)
    (mapcar #'(lambda (x) (setf (get x 'vl) T)) S2)
    (dolist (el S1 S2)
        (if (not (get el 'vl)) (setf S2 (cons el S2)))
    )
    (mapcar #'(lambda (x) (setf (get x 'vl) ())) S2)
    S2
)


Zadání: Binární strom Edit

Binární strom

(defun Koren (Strom) (cadr Strom))
(defun Levy (Strom) (car Strom))
(defun Pravy (Strom) (caddr Strom))
(defun Vytvor (Levy Koren Pravy) (list Levy Koren Pravy))
(defun Prazdny() ())
(defun Prazdnyp(Strom) (if (null Strom) T ()))
(defun ZmenL (Strom LevyPS) (rplaca Strom LevyPS))
(defun ZmenP (Strom PravyPS) (rplaca (cddr Strom) PravyPS) Strom)
(defun ZmenK (Strom KorenNovy) (rplaca (cdr Strom) KorenNovy) Strom)

(defun In (Prvek Strom Usp)
    (cond   ((Prazdnyp Strom) ())
            ((equal Prvek (Koren Strom)) T)
            ((funcall Usp Prvek (Koren Strom)) (In Prvek (Levy Strom) Usp))
            (T (In Prvek (Pravy Strom) Usp))
)  )

(defun Add (Prvek Strom Usp)
    (cond   ((Prazdnyp Strom) (Vytvor (Prazdny) Prvek (Prazdny)))
            ((equal Prvek (Koren Strom)) Strom)
            ((funcall Usp Prvek (Koren Strom))
                (Vytvor (Add Prvek (Levy Strom) Usp)
                        (Koren Strom)
                        (Pravy Strom)
                )
            )
            (T
                (Vytvor (Levy Strom)
                        (Koren Strom)
                        (Add Prvek (Pravy Strom) Usp)
)   )      ) )

(defun Del (Prvek Strom Usp)
    (cond   ((Prazdnyp Strom) (Prazdny))
            ((equal Prvek (Koren Strom))
                (cond   ((Prazdnyp (Levy Strom)) (Pravy Strom))
                        ((Prazdnyp (Pravy Strom)) (Levy Strom))
                        (T (let ((P (Delmin (Pravy Strom))))
                                (Vytvor (Levy Strom)
                                        (car P)
                                        (cdr P)
                                )
                            )
                        )
                )
            )
            ((funcall Usp Prvek (Koren Strom))
                (Vytvor (Del Prvek (Levy Strom) Usp)
                        (Koren Strom)
                        (Pravy Strom)
                )
            )
            (T
                (Vytvor (Levy Strom)
                        (Koren Strom)
                        (Del Prvek (Pravy Strom) Usp)
)   )      ) )

(defun Delmin (Strom) (Delpom Strom (Levy Strom)))

(defun Delpom (SHorni SLevy)
    (cond   ((Prazdnyp SLevy) (cons (Koren SHorni) (Pravy SHorni)))
            (T  (progn
                    (setq SLevy (Delpom SLevy (Levy SLevy)))
                    (cons   (car SLevy)
                            (Vytvor (cdr SLevy)
                                    (Koren SHorni)
                                    (Pravy SHorni)
)   )       )  )   )   )

(defun UIn (Prvek Strom Usp)
    (UInPom Prvek Strom Usp ())
)

(defun UInPom (Prvek Strom Usp Path)
    (cond   ((Prazdnyp Strom) ())
            ((equal Prvek (Koren Strom)) (cons Prvek Path))
            ((funcall Usp Prvek (Koren Strom) ) (UInPom Prvek (Levy Strom) Usp (cons (Koren Strom) Path)))
            (T (UInPom Prvek (Pravy Strom) Usp (cons (Koren Strom) Path)))
)  )

Zadání: Databaze Edit

Databaze

;;; U - binarni vektor, V - vektor
(defun vect(U V)
    (mapcan #'(lambda (X Y) (if (= X 1) (list Y) ())) U V)
)

(defun dbProj(Db Pr)
    (let ((binvect (findBin (car Db) Pr)))
        (if (null binvect)
            ()
            (mapcar #'(lambda (X) (vect binvect X)) Db)
)   ) )

(defun findBin2 (DbHead Pr Vect)
    (cond   ((and (null Pr) (null DbHead)) Vect)
            ((null Pr) (findBin2 (cdr DbHead) Pr (append Vect (list 0))))
            ((null DbHead) ())
            ((eq (car DbHead) (car Pr)) (findBin2 (cdr DbHead) (cdr Pr) (append Vect (list 1))))
            (T (findBin2 (cdr DbHead) Pr (append Vect (list 0))))
)  )

(defun findBin (DbHead Pr) (findBin2 DbHead Pr ()))

Zadání: Substituce s testem zacykleni Edit

Substituce s testem zacykleni

(defun occursCheck (P)
    (do ((R P (cdr R)))
        ((null R) ())
        (if (findSubst (caar R) (cdar R) P) (return T))
    )
)

(defun findSubst(A S P)
    (cond   ((null S) ())
            ((atom S)   (if (eq A S)
                            T
                            (let ((Q (assoc S P)))
                                (or (immCheck (car Q) (cdr Q))
                                    (findSubst A (cdr (assoc S P)) P)
                                )
                            )
                        )
            )
            (T (or (findSubst A (car S) P) (findSubst A (cdr S) P)))
)  )

(defun immCheck (A S)
    (cond   ((null S) ())
            ((atom S) (eq A S))
            (T (or (immCheck A (car S)) (immCheck A (cdr S))))
)  )

(defun substAll (P S)
    (cond   ((null S) ())
            ((atom S)   (let ((Q (assoc S P)))
                            (if (null Q)
                                S
                                (substAll P (cdr Q))
                            )
                        )
            )
            (T (cons (substAll P (car S)) (substAll P (cdr S))))
)  )

PROLOG:

%msubst([a,b,b,a], [x,y,y,x]) --> yes.

member(X,[X|_]).
member(Y,[_|S]):-
    member(Y,S).

msubst(A,B):-
    msubst2(A,B,[]).

msubst2([],[],_).
msubst2([X|A],[Y|B],O):-
    (member([X,_],O);member([Y,_],O)),!,
    member([X,Y],O),
    msubst2(A,B,O).
msubst2([X|A],[Y|B],O):-
    msubst2(A,B,[[X,Y],[Y,X]|O]).

Zadání: Tranzitivni uzaver Edit

PROLOG:

%tuzaver([a,b],[b,c])-->[[a,b],[b,c],[a,c]]


najdi(A,[A|_],A).
najdi(A,[B|S],Out):-
    najdi(A,S,Out).

tuzaver([A|S], Out):-
    tuz2(A,S, Out1),
    eldupl(Out1, Out).

tuz2(S,[],[S]).
tuz2([X,Y], [B|S], [[X,Y]|Out]):-
    findall([X,Q],najdi([Y,_],[B|S], [P,Q]), O),!,
%    write([X,Y]),nl,
%    write(O),nl,nl,
    tuz2(B,S, Out2),
    append(O, Out2, Out).

append(A, B, Out):-
    reverse(A, AR),
    append2(B, AR, Out1),
    reverse(Out1, Out).

append2([], B, B).
append2([X|A], B, Out):-
    append2(A, [X|B], Out).

eldupl([],[]).
eldupl([A|S],Out):-
    member(A,S),!,
    eldupl(S,Out).
eldupl([A|S],[A|Out]):-
    eldupl(S,Out).

Zadání: Antisymetrie relace Edit

PROLOG:

%antisym([[a,b],[b,a]])-->no.

antisym([]).
antisym([[X,Y]|R]):-
    najdi([Y,X],R, [Y,X]),!,fail.
antisym([[X,Y]|R]):-
    antisym(R).

Zadání: Huffmanovo kodovani Edit

PROLOG:

%vyrobeni stromu
huffTree(C, Out):-
    makeNodes(C, C1),
    huffTree2(C1, Out).

makeNodes([],[]).
makeNodes([[H,P]|S], [[[],H,P,[]]|Out]):-
    makeNodes(S,Out).

huffTree2([C], C):-!.
huffTree2(C, Out):-
%    write('Hufftree2'),nl,
%    write('Vstup: '),write(C),nl,
    extMin(C, [L1, H1, O1, P1], C1),
%    write('Min1: '),write([L1,H1, O1, P1]),nl,
    extMin(C1, [L2, H2, O2, P2], C2),
%    write('Min2: '),write([L2,H2, O2, P2]),nl,
%    write('Vystup: '),write(C2),nl,
    H is H1+H2,
    huffTree2([[[L1, H1, O1, P1], H ,[],[L2, H2, O2, P2]]|C2], Out).


extMin([Min|C], OutMin ,C1):-
    extMin2(C, Min, OutMin, C1).

extMin2([], Min, Min, []).
extMin2([[L,H,O,P]|C], [LM,HM,OM,PM], Min,[[LM,HM,OM,PM]|C1]):-
    H<HM,!,
    extMin2(C, [L,H,O,P], Min, C1).
extMin2([[L,H,O,P]|C], [LM,HM,OM,PM], Min,[[L,H,O,P]|C1]):-
    extMin2(C, [LM,HM,OM,PM], Min, C1).

testextmin(S, Out1, Out2):-
    makeNodes(S, S1),
    extMin(S1, Out1, Out2).


%vyrobeni tabulky kodovani
tabulka(S):-
    assert(kod(a,b)),
    kill(kod),
    huffTree(S, S1),
    preorder(S1,[]),
    !.

preorder([], V):-fail.
preorder([L, H, [], P], V):-
    preorder(L, [0|V]),
    preorder(P, [1|V]),!.
preorder([L, H, O, P], V):-
    preorder(L, [0|V]),
    preorder(P, [1|V]),
    reverse(V, V1),
    assert(kod(O, V1)),!.
preorder(_, _).


%odstraneni zbytecnych dat ze stromu
odstran(Seznam, Out):-
    huffTree(Seznam, Strom),
    odstran2(Strom, Out).

odstran2([],[]).
odstran2([L, H, O, P], [Out1, O, Out2]):-
    odstran2(L, Out1),
    odstran2(P, Out2).

Zadání: Lomena cara Edit

PROLOG:

%uzavrenost
uzavrena(Zac, S):-
    uzavrena2(Zac, Zac, S).

uzavrena2(P,P,[]).    
uzavrena2([PX,PY],K,[u|S]):-
    Y is PY-1,
    uzavrena2([PX, Y], K, S).
uzavrena2([PX,PY],K,[d|S]):-
    Y is PY+1,
    uzavrena2([PX, Y], K, S).
uzavrena2([PX,PY],K,[l|S]):-
    X is PX-1,
    uzavrena2([X, PY], K, S).
uzavrena2([PX,PY],K,[r|S]):-
    X is PX+1,
    uzavrena2([X, PY], K, S).


%protinani - pocitam i bod na konci, nemusi byt uzavrena
pruseciky(Zac, S, Out):-
    pruseciky2(Zac, Zac, S, [Zac], 0, Out).

pruseciky2(_,_,[],_, Cnt, Cnt).
pruseciky2([PX,PY],K,[u|S],Fr, Cnt, Out):-
    Y is PY-1,
    member([PX,Y], Fr),!,
    Cnt2 is Cnt+1,
    pruseciky2([PX,Y], K, S, Fr, Cnt2, Out).
pruseciky2([PX,PY],K,[u|S],Fr, Cnt, Out):-
    Y is PY-1,
    pruseciky2([PX,Y], K, S,[[PX,Y]|Fr], Cnt, Out).

pruseciky2([PX,PY],K,[d|S],Fr, Cnt, Out):-
    Y is PY+1,
    member([PX,Y], Fr),!,
    Cnt2 is Cnt+1,
    pruseciky2([PX,Y], K, S, Fr, Cnt2, Out).
pruseciky2([PX,PY],K,[d|S],Fr, Cnt, Out):-
    Y is PY+1,
    pruseciky2([PX,Y], K, S,[[PX,Y]|Fr], Cnt, Out).

pruseciky2([PX,PY],K,[r|S],Fr, Cnt, Out):-
    X is PX+1,
    member([X,PY], Fr),!,
    Cnt2 is Cnt+1,
    pruseciky2([X,PY], K, S, Fr, Cnt2, Out).
pruseciky2([PX,PY],K,[r|S],Fr, Cnt, Out):-
    X is PX+1,
    pruseciky2([X,PY], K, S,[[X,PY]|Fr], Cnt, Out).

pruseciky2([PX,PY],K,[l|S],Fr, Cnt, Out):-
    X is PX-1,
    member([X,PY], Fr),!,
    Cnt2 is Cnt+1,
    pruseciky2([X,PY], K, S, Fr, Cnt2, Out).
pruseciky2([PX,PY],K,[l|S],Fr, Cnt, Out):-
    X is PX-1,
    pruseciky2([X,PY], K, S,[[X,PY]|Fr], Cnt, Out).


%konvexita, konkavita, obsah
kS([A|S], Out):-
    uzavrena([1,1], [A|S]),
    konvexni(S, [], A),
    obsah([A|S],0,0,Out).

konvexni([],_,_).
konvexni([A|S], Fr, A):-
    konvexni(S, Fr, A),!.
konvexni([B|S], Fr, A):-
    member(B, Fr),!,fail.
konvexni([B|S], Fr, A):-
    konvexni(S,[A|Fr], A).

obsah([], A, B, Out):-Out is A*B.
obsah([u|S], A, B, Out):-
    AA is A+1,
    obsah(S, AA,B,Out).
obsah([d|S], A, B, Out):-
    obsah(S, A,B,Out).
obsah([r|S], A, B, Out):-
    BB is B+1,
    obsah(S, A,BB,Out).
obsah([l|S], A, B, Out):-
    obsah(S, A,B,Out).

Zadání: Reflexivita relace Edit

PROLOG:

reflex(S):-
    reflex2(S, S).

reflex2([],_).
reflex2([[X|X]|S],Q):-
    reflex2(S,Q),!.
reflex2([[X|Y]|S],Q):-
    member([X|X], Q),
    member([Y|Y], Q),
    reflex2(S, Q).

Zadání: Dosazitelnost - Gamma Star Edit

PROLOG:

gammaStar(S, A, Out):-
    gammaStar2(S, [A], [], Out1),
    reverse(Out1, Out).

gammaStar2(_,[],Out,Out).
gammaStar2(P, [A|Open], X, Out):-
    member(A, X),!,
    findDel(P,A, Q, Sousedi),
    append(Open, Sousedi, Open2),
%    write(Open2),nl,
    gammaStar2(Q, Open2, X, Out).
gammaStar2(P, [A|Open], X, Out):-
    findDel(P,A, Q, Sousedi),
    append(Open, Sousedi, Open2),
%    write(Q),nl,
%    write(Open2),nl,
%    write([A|X]),nl,nl,
    gammaStar2(Q, Open2, [A|X], Out).


findDel([[Node|Sousedi]|NSzn], Node, NSzn, Sousedi):-!.
findDel([[JNode|Nasl]|Zbytek], Node, [[JNode|Nasl]|NSzn], Sousedi):-
    findDel(Zbytek, Node, NSzn, Sousedi).
findDel([],_,[],[]).

Ad blocker interference detected!


Wikia is a free-to-use site that makes money from advertising. We have a modified experience for viewers using ad blockers

Wikia is not accessible if you’ve made further modifications. Remove the custom ad blocker rule(s) and the page will load as expected.