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.[]
Ř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.[]
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))) )
) )
Trosku efektivnejsi reseni pres mapovaci funkcional ;)
;;;mapcan je tam kvuli tomu ze umoznuje nejaky prvky vypustit - pokud jsou nil
;;;jinak se da podobneho vysledku docilit i pomoci mapcar ale budou tam NILy
(defun sub (b s)
(mapcan
#'(lambda (x y)
(cond ((not(zerop x)) (list y))))
b s)
)
Zadání: Potenční množiny.[]
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[]
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: Při volání třetí a čtvrtý parametr NIL a 0.
(defun testopak (s v uv n)
(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)
) )
Jeste pres mapovaci funkcionaly to je teoreticky rychlejsi je tam hezkej figl ;)
Pocita i prekryvajici se vzory
mapcon vrati list jehoz obsahem budou T velikosti rovne poctu opakovani
(defun testopak (s v)
(length
(mapcon #'(lambda (x)
(if (>= (mismatch v x) (length v))
(list T)))
s)
))
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í.[]
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-relaci(a b)
(mapcan #'(lambda(xa)
(mapcan #'(lambda(xb)
(if (eq (cdr xa) (car xb))
(list (cons (car xa) (cdr xb))))) b)) a)
)
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í.[]
Test na prosté zobrazení.
(proste '((a . 1)(b . 1))) --> nil (proste '((a . 2)(b . 1))) --> t
LISP: Při volání druhý parametr NIL.
(defun proste (s o)
(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))
()
(prRek2 (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[]
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 skip-x (lst x)
(if (zerop x) lst
(skip-x (cdr lst) (- x 1))))
(defun pocet-neprekryv (patt lst)
(let ((len (length patt)))
(cond ((null lst) 0)
((>= (mismatch lst patt) len) (+ 1 (pocet-neprekryv patt (skip-x lst len))))
(t (pocet-neprekryv patt (cdr lst))))
))
;//O~P
(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[]
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[]
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: Řešení s hash tabulkou
(defun testtah-pom (lst ht last)
(cond ((null lst) t)
((and (null (gethash (car lst) ht)) (eql (cdr last) (caar lst)))
(setf (gethash (car lst) ht) 1)
(testtah-pom (cdr lst) ht (car lst)))
(t nil))
)
(defun testtah (lst)
(let ((ht (make-hash-table :test #'equal)))
(testtah-pom lst ht (cons nil (caar lst)))
))
(defun testtah (s)
(testuj (car s) (cdr s) nil)
)
(defun testuj (p s h) ; polozka (jedna hrana), cesta, pouzite hrany
(cond ( (clen p h) NIL )
( (null s) T )
( (eq (cdr p) (caar s)) (testuj (car s) (cdr s) (cons p h)) )
) )
(defun clen (p h) ; misto member, musim pouzit equal a ne eq
(cond ( (null h) NIL )
( (equal p (car h)) T )
( T (clen p (cdr h)) )
) )
;;EDIT: upresneni - neni treba pouzivat clen jde pouzit member ale je treba zadat key
;;nasledovne:
(defun testuj (p s h)
(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[]
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)))
) ) ) ) )
Pres map a hash tabulku - plan je nasledovny - nahasuju si jednotlive vrcholy a je jich nasledovniky a to pak jen vyplivnu
(defun sousedi (s)
(let ((ht (make-hash-table)) (outlist nil))
(mapcar #'(lambda (x)
(setf (gethash (car x) ht) (cons (cadr x) (gethash (car x) ht))))
s)
(maphash #'(lambda (k v)
(setf outlist (cons (append (list k) v) outlist)))
ht)
outlist))
No pokud by se stalo - a to se muze lehce stat... ;) ze by bylo potreba vypsat i vrcholy co nemaji nasledovniky ve stylu:
((a b) (a c) (b d) (d c) (b c)) --> ((A C B) (B E D) (D C) (C) (E))
tedy Vrcholova reprezentace grafu nebo jak se tomu nadava tak to je malinko slozitejsi:
(defun sousedi (s)
(let ((ht (make-hash-table)) (outlist nil))
(mapcar #'(lambda (x)
(setf (gethash (car x) ht) (cons (cadr x) (gethash (car x) ht))))
s)
(mapcar #'(lambda (x)
(if (null (gethash (cadr x) ht)) (setf (gethash (cadr x) ht) nil)))
s)
(maphash #'(lambda (k v)
(setf outlist (cons (append (list k) v) outlist)))
ht)
outlist))
Pribyva tam navic jeste jedno projiti seznamu jestli nahodou se nejaky nasledovnik nevyskytuje jeste jednou
Zadání: Nejopakovanejsi pismeno[]
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) )
) )
Pres MAP funkcionaly a HASH tabulku:
(defun nejopak (list)
(let ((HT (make-hash-table)) (outlist nil))
;;na mapuju do hash tabulky ke kazdymu cislu pocet vyskytu
(mapc #'(lambda (c)
(if (gethash c HT) (incf (gethash c HT))
(setf (gethash c HT) 1)))
list)
;; pak si je nahazim do jednoho seznamu
(maphash #'(lambda (k v) (setf outlist (cons (cons k v) outlist))) HT)
;;a ten sortnu podle poctu vyskytu a vratim prvni prvek ;)
(car (sort outlist #'> :key #'cdr))))
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?[]
Seznam bodu (x . y), alespon 2 body. Zjistete, zda dane body lezi v 1 primce.
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[]
Je dan seznam (x . F(x)). Udelejte fci, ktera overi, ze dany seznam je rostouci funkce.
LISP:
(defun je-rostouci (lst)
(sort lst #'(lambda(x y) (< (car x) (car y)))) ;nejdriv seradime posloupnost
(let ((last (car lst)))
(dolist (x (cdr lst))
(cond ((eql (car last) (car x)) (return-from je-rostouci nil)) ;neni funkce
((>= (cdr x) (cdr last)) (setf last x)) ;zapamatovani dalsiho last
(t (return-from je-rostouci nil))))) ;neni rostouci
t
)
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[]
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[]
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)
)
LISP3: dukaz ze pres mapovaci funkcional jde i tohle ;)
(defun histogram (&rest s)
(let ((g (copy-list s))) ;musim skopcit seznam protoze mi ho sort zlikviduje
(mapc #'(lambda (x)
(mapc #'(lambda (y) (if (>= y x)
(princ "X ")
(princ " ")))
g)
(terpri))
(sort s #'>))
;; a jete ty pomlcky jestli je to nutny
(dotimes (i (length S) T) (format T "--")
))
Zadání: Sachovnice[]
Sachovnice
Asi tohle zadani:
1) sachovnice 1..n x 1..n na ni je dan seznam zakazanych zon, asi tak: S = ((xh1,yh1,xd1,yd1) ... (xhn,yhn,xdn,ydn)) kde index h znamena horni roh a d dolni roh oblasti i (i=1..n) ukoly: a) TestD(S1,S2) - predikat disjunktnosti 2 oblasti b) TestIn(S1,S2) - nalezeni nejmensiho obdelniku, do ktereho se vejdou oba c) funkce pro vypocet jejich pruniku, pokud maji d) e) uz nevim - obdobne 2) v teto sachovnici mate pocatecni (A=[x1,y1]) a cilovy bod (B=[xn,yn]), najdete nejkratsi cestu mezi A a B, tak abyste neprochazeli zakazanymi oblastmi (S) 3) najdete vsechny radky a vsechny sloupce (2 funkce zvlast), ktere neprotina zadna ze zak. oblasti
Alternativni reseni k drive jiz uverejnenemu. Snad bude i lepe pochopitelne
;Pomocne funkce pro lepsi pristup k promennym oblasti
(defun get-x1(area)
(nth 0 area))
(defun get-x2(area)
(nth 2 area))
(defun get-y1(area)
(nth 1 area))
(defun get-y2(area)
(nth 3 area))
; vrati oblast takovou, ze x1,y1 bude dolni levy roh
(defun normalize(area)
(when (> (get-x1 area) (get-x2 area))
(setf area (list (get-x2 area) (get-y1 area) (get-x1 area) (get-y2 area))))
(when (> (get-y1 area) (get-y2 area))
(setf area (list (get-x1 area) (get-y2 area) (get-x2 area) (get-y1 area))))
area)
; zadefinovani nekolika globalnich promennych a ACCESSOR funkci k nim
(let ((areas nil) (dim 8) )
(defun get-areas()
areas
)
(defun set-areas(lst)
(setf areas nil)
(mapc #'(lambda(x) (setf areas (cons (normalize x) areas))) lst))
(defun get-dim()
dim)
(defun set-dim(d)
(setf dim d))
)
;1. ULOHA
;test disjunknosti
(defun TestD(S1 S2)
(cond ((< (get-x2 S1) (get-x1 s2)) t) ;S2 napravo od S1
((> (get-x1 S1) (get-x2 s2)) t) ;S1 nalevo od S2
((< (get-y2 S1) (get-y1 s2)) t) ;S2 nahore od S1
((> (get-y1 S1) (get-y2 s2)) t) ;S1 dole od S2
(t nil))
)
;nemensi obdelnik do ktereho se oba vejdou
(defun TestIn (S1 S2)
(list (min (get-x1 S1) (get-x1 S2))
(min (get-y1 S1) (get-y1 S2))
(max (get-x2 S1) (get-x2 S2))
(max (get-y2 S1) (get-y2 S2))))
;vypocet pruniku
(defun Prunik(S1 S2)
(if (TestD S1 s2)
nil
(list (max (get-x1 S1) (get-x1 S2))
(max (get-y1 S1) (get-y1 S2))
(min (get-x2 S1) (get-x2 S2))
(min (get-y2 S1) (get-y2 S2))))
)
; otestuje zda policko nelezi uvnitr nejake zakazane oblasti
(defun banned-coordinate(x y)
(mapc #'(lambda(area)
(when (and (>= x (get-x1 area)) (<= x (get-x2 area))
(>= y (get-y1 area)) (<= y (get-y2 area)))
(return-from banned-coordinate t))) (get-areas))
nil
)
;2. ULOHA : reseni BFS
; v hashi budou policka odkud bylo na dane pole prijito
(defun visit(x y info from)
;nenavstivime policka za okrajem sachovnice
(when (< x 0) (return-from visit nil))
(when (< y 0) (return-from visit nil))
(when (>= x (get-dim)) (return-from visit nil))
(when (>= y (get-dim)) (return-from visit nil))
;zakazana policka nenavstevujeme
(when (banned-coordinate x y) (return-from visit nil))
;navstivene policka jiz nenavstevujeme
(when (not (gethash (cons x y) info))
(setf (gethash (cons x y) info) from)
(return-from visit t))
nil
)
;seznam nenavstivenych bodu okolo jednoho policka
(defun get-unvisited-neighbours (x y info)
(let ((retval))
(when (visit (+ x 1) y info (cons x y)) (setf retval (cons (cons (+ x 1) y) retval)))
(when (visit (- x 1) y info (cons x y)) (setf retval (cons (cons (- x 1) y) retval)))
(when (visit x (+ y 1) info (cons x y)) (setf retval (cons (cons x (+ y 1)) retval)))
(when (visit x (- y 1) info (cons x y)) (setf retval (cons (cons x (- y 1)) retval)))
retval
)
)
;BFS
(defun BFS(hood info target)
(if (member target hood :test #'equal)
t
(let ((new-hood nil))
(cond ((null hood) nil)
(t (mapc #'(lambda (x)
(setf new-hood (union new-hood (get-unvisited-neighbours (car x) (cdr x) info) :test #'equal)))
hood)
(BFS new-hood info target))))
))
; ziska cestu ze zpetnych pointru v hash tabulce info
(defun get-path (from target info)
(let ((retval nil))
(loop
(print target)
(read)
(when (null target) (return-from get-path nil))
(setf retval (cons target retval))
(when (equal target from) (return-from get-path (reverse retval)))
(setf target (gethash target info))
)
))
(defun testproc ()
(let ((info (make-hash-table :test #'equal)))
(set-dim 10)
(set-areas '((1 2 5 5)))
;TEST 2:
;(BFS '((1 . 1)) info '(9 . 9))
;(get-path '(1 . 1) '(9 . 9) info)
;TEST 3:
(princ (get-free-colums))(terpri)
(princ (get-free-rows))
t
))
;3. ULOHA
;vrati seznam sloupecku, do kterych nezasahuje jedina oblast
(defun get-free-colums()
(let ((free t) (retval))
(dotimes (x (get-dim))
(setf free t)
(dotimes (y (get-dim))
(when (banned-coordinate x y) (setf free nil)))
(when free (setf retval (cons x retval))))
retval)
)
;vrati seznam radku, do kterych nezasahuje jedina oblast
(defun get-free-rows()
(let ((free t) (retval))
(dotimes (y (get-dim))
(setf free t)
(dotimes (x (get-dim))
(when (banned-coordinate x y) (setf free nil)))
(when free (setf retval (cons y retval))))
retval)
)
;//O~P
(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[]
Boolovsky vyraz je:
BV -> 0 | 1 | Promena | (NOT BV) | (OR (BV)*) | (AND (BV)*)
napiste funkce:
Test(BV) - otestuje spravnost
Var(BV) - vrati seznam promenych
Eval(BV A) - vrati hodnotu BV. Hodnoty promenych jsou v seznamu A =((A . 1) (B . 0) ...)
Taut(BV) - vrati T pokud je BV tautologie (vzdy jedna)
(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[]
Mame kostky domina, kde jsou cisla reprezentovany pismeny A...F. Napiste funci, ktera zjisti zda je lze poskladat do jedne rady. A to podle pravidel domina. Tzn. po (A . B) musi prijit (B . NECO), atd. Vstup je seznam D = ((A . B) (B . D) (C . A) .....)
(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))
) ) )
(defun mydom (posl S)
(format t "posl=~A S=~A ~%" posl S)
(if (= (length S) 0)
(return-from mydom T)
(mapcar #'(lambda (X)
(if (eql (car X) posl)
(if (mydom (cdr X) (remove X S))
(return-from mydom T)))) S))
nil)
(defun domino (S)
(mapcar #'(lambda (X)
(if (mydom (cdr X) (remove X S))
(return-from domino T))) S)
nil)
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[]
Mame 2 posloupnosti atomu P a Q. (Tzn. (a b c a b c), apod.). Napiste funkci ktera zjisti, zda lze prelozit prvni posloupnost na druhou. Priklady:
(preklad '(a b b a) '(x y y x)) --> T (preklad '(a b c b a) '(x x y x x)) --> NIL (preklad '(a b c b a) '(x y z y x)) --> T
(defun preklad(a b &optional (ht (make-hash-table)) (htrev (make-hash-table)))
;(format t "~a ~a~%" (Car a) (car b))
(cond ((and (null a) (null b)) t)
((and (null a) (not (null b))) nil)
((and (null b) (not (null a))) nil)
((and (null (gethash (car a) ht)) (null (gethash (car b) htrev)))
(setf (gethash (car a) ht) (car b))
(setf (gethash (car b) htrev) (car a))
(preklad (cdr a) (cdr b) ht htrev))
((eq (gethash (car a) ht) (car b)) (preklad (cdr a) (cdr b) ht htrev))
(t nil))
)
;//O~P
Zadání: Odpovidajici si seznamy[]
Mame dva seznamy P a Q, obecne viceurovnove. Napiste funkci, ktera zjisti zda si tyto seznamy "odpovidaji".
Relace "odpovidaji" je definovana takto:
- pokud je prvkem prvniho cislo, pak na stejne pozici druheho musi byt cislo stejne hodnoty
- pokud je prvkem prvniho atom, pak na stejne pozici muze byt jakykoliv S-vyraz (tedy: NIL, atom, seznam, cislo, ...)
- pokud je prvkem prvniho seznam, pak na stejne pozici musi byt seznam, jehoz prvky si "odpovidaji" a je stejne dlouhy
(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 ())
) )
Trochu komprimovanejsi verze ;-)
(defun odpovidajici (a b)
(cond ((and (null a) (null b)) t)
((and (symbolp a) (or (atom b)) (listp b)) t)
((and (atom a) (atom b) (eq a b)) t)
((and (listp a) (listp b)) (and (odpovidajici (car a) (car b)) (odpovidajici (cdr a) (cdr b))))
(t nil))
)
;//O~P
Zadání: Nalezeni orientovaneho tahu[]
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[]
Zadani viz: Vypsání podmnožiny podle vektoru.
LISP
(defun vect(U V)
(mapcan #'(lambda (X Y) (if (= X 1) (list Y) ())) U V)
)
Zadání: Transitivni relace[]
Napište funkci, ktera vraci T nebo NIL podle toho, jestli relace zadana seznamem tecka dvojic je Tranzitivni.
(transitivni '( (a . b) (c . b) (b . c) )) ---> NIL (transitivni '( (a . b) (b . c) (a . c ))) ---> T
Minimalistická verze
(defun transitivni (lst)
(dolist (x lst) ;iterace pres vsechny kombinace
(dolist (y lst)
(when (eq (cdr x) (car y)) ;pokud se spolu zaznamy paruji -> kontrola transitivity
(when (not (member (cons (car x) (cdr y)) lst :test #'equal))
(return-from transitivni nil)))))
t
)
;//O~P
(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[]
Funkce, ktera testuje, jestli je cesta v grafu zadana seznamem posloupnosti hran otevrenou cestou (a neprazdnou) ...
((a.b)(b.c)(c.d)(d.e)) -> T ((a.b)(b.c)(c.b)(b.e)) -> NIL
(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[]
Funkce testuje, jestli je jeden seznam atomu ekvivalentni druhemu, az na mozne substituce a vraci seznam techto substituci.
(a b c),(x y z) -> ((a.x)(b.y)(c.z)) (a b c),(x x z) -> NIL
(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[]
Navrhnout reprezentaci stromu, ktery muze mit libovolny vystupni stupen uzlu (libovolny pocet podstromu) a pro nej naimplementovat:
- Destruktivni vlozeni podstromu S do stromu T na danou pozici M
- Hloubku stromu T
- Max. vystuni stupen ve stromu T
- Ziskani prvku z dane pozice M
Pozice se udavala jako seznam poradi v jednotlivych podstromech ... nevim, jak to popsat rozumne, ale mel u toho hezkej obrazek, ze kteryho se to dalo dobre pochopit o co jede ...
Strom = (a (b (e) (f)) (c (d (h) (i) (j))))
Pozice `j` je M = (2 1 3)
(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[]
Mame relaci R danou seznamem dvojic ((neco.neco) (neco.neco)...) a mame zjistit jestli je reflexivni.
(reflex '((a . b) (b . c) (d . a) (a . a) (b . b))) ---> NIL (reflex '((a . b) (b . c) (d . a) (a . a))) ---> NIL (reflex '((a . b) (b . c) (d . a) (a . a) (b . b) (d . d))) ---> T
(defun reflex(lst)
(dolist (x lst)
(when (not (member (cons (car x) (car x)) lst :test #'equal))
(return-from reflex nil)))
t)
;//O~P
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[]
Funkce zobrazi vsechny mozne podmnoziny zadane mnoziny asi nasledovne:
>(powerset '(A B C D)) ((A B C D) (A B C) (A B D) (A B) (A C D) (A C) (A D) (A) (B C D) (B C) (B D) (B) (C D) (C) (D) NIL)
(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[]
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[]
Funkce vypise pocet opakovani podposloupnosti.. no viz priklad:
(a b a b a b a b a b a b) (a b a b) -> 3 (a b a b a b a b c d a b a b) (a b a b) -> NIL
Minimalisticka verze
(defun period(lst patt)
(cond ((null lst) 0)
((and (mismatch lst patt) (< (mismatch lst patt) (length patt))) nil)
(t (+ 1 (period (nthcdr (length patt) lst) patt)))))
;//O~P
(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[]
Uff nevim proč to tu je je to to samý co 1.
Řetězení za sebe podseznamů a délek.
(defun makeit (S)
(append (mapcon #'(lambda (X) (append X (list (length X)))) S) (list () 0))
)
Zadání: Moje sjednoceni[]
Obecné sjednoceni pro libovolný počet seznamu. Tedy plne napodobuje standartni lispovsky union.
(my-union '(1 2 3 ) '(1 2 3 ) '(1 2 3 5 6 a ) ) ---> (A 6 5 3 2 1)
(defun my-union(&rest lst)
(let ((retval nil))
(mapc #'(lambda(&rest x)
(mapc #'(lambda(y)
(when (not (member y retval :test #'equal))
(setf retval (cons y retval)))) (car x))) lst)
retval)
)
;//O~P
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[]
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[]
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[]
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[]
LISP:
Obecny pristup k uzaverum jako takovym.
;obecna funkce pro libovolny uzaver
(defun uzaver (match generate lst)
(let ((new-items nil))
(dolist (x lst) ;iterace pres vsechny kombinace relaci
(dolist (y lst)
(when (funcall match x y) (setf new-items (adjoin (funcall generate x y) new-items :test #'equal)))))
(setf new-items (union new-items lst :test #'equal))
(if (eq (length new-items) (length lst)) ;porovnani delek seznamu, pokud stejne ->konec jinak rekurze
new-items
(uzaver match generate new-items))
))
(defun trans-match(x y)
(eq (cdr x) (car y)))
(defun trans-generate(x y)
(cons (car x) (cdr y)))
(defun tranzitivni-uzaver (lst)
(uzaver #'trans-match #'trans-generate lst))
;//O~P
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[]
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[]
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[]
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[]
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 v grafu[]
LISP:
(dosazitelnost '( (a . b) (a . c) (b . b)(b . c)(d . a)(c . e)(e . c)) 'b 'a)
Tak tohle byl trochu orisek, ale snad to bude z komentaru a kodu jasne, co to dela
;pomocna struktura, kde je lozeno jestli byl uzel jiz navstiven + jeho hrany
(defstruct uzel
visited
edges)
;navstivi uzel, pokud byl jiz navstiven vraci nil
(defun visit (u graf)
(let* ((ch (gethash u graf))
(retval (uzel-visited ch)))
(setf (uzel-visited ch) t)
(not retval)))
;konstukce hash tabulky s grafem
(defun build-graf (lst graf)
(cond ((null lst) t)
((null (gethash (caar lst) graf))
(let ((new (make-uzel)))
(setf (uzel-edges new) (cons (cdar lst) nil))
(setf (gethash (caar lst) graf) new)
(build-graf (cdr lst) graf)))
(t (let ((u (gethash (caar lst) graf) ))
(setf (uzel-edges u) (cons (cdar lst) (uzel-edges u)))
(build-graf (cdr lst) graf))))
)
; z jednoho grafu ziska vsechny nenavstivene uzly, pro ktere existuje hrana
(defun visit-neighbour (man graf)
(mapcan #'(lambda (x)
(when (visit x graf) (list x))) (uzel-edges (gethash man graf))
))
;pro cely seznam uzlu zjisti mnozinu nenavstivenych sousedu
;+hleda v okoli cilovy stav a neprestane dokud nenavstivi vsechny dostupne uzly
(defun visit-neighbourhood (lst target graf)
(print lst)
(when (member target lst) (return-from visit-neighbourhood t))
(let ((new-hood nil))
(cond ((null lst) (return-from visit-neighbourhood nil))
(t (mapc #'(lambda (x) (setf new-hood (union new-hood (visit-neighbour x graf)))) lst)))
(visit-neighbourhood new-hood target graf)
))
; spousteci funkce
(defun dosazitelnost (lst from to)
(if (eq from to )
t
(let ((graf (make-hash-table)))
(build-graf lst graf)
;(maphash #'(lambda (k v) (format t "~A ~A~%" k (uzel-edges v))) graf)
(visit-neighbourhood (list from) to graf)))
)
;//O~P
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([],_,[],[]).
Zadání: Prohledávání do hloubky v grafu (DFS)[]
Nad grafem zadaneho v podobe matice souslednosti vytvorte seznam navstevovanych uzlů algoritmem DFS i s časovými razítky vstupu a opuštění uzlu.
Vstup : graf -'( (a . b) (a . c) (b . b)(b . c)(d . a)(c . e)(e . c)) ; start - 'a Výstup : ((A 0 -1) (C 1 -1) (E 2 -1) (E 2 3) (C 1 4) (B 5 -1) (B 5 6) (A 0 7)) ***(uzel cas_stupu cas_vystupu)
(let ((time 0) (visit-map (make-hash-table)))
;reset ulohy
(defun reset-time()
(setf time -1)
(setf visit-map (make-hash-table)))
;inkrementace casoveho razitka
(defun tick()
(incf time))
;oznaci uzel za navstiveny a vraci zda byl uzel jiz v minulosti navstiven
(defun visit(u)
(when (gethash u visit-map)
(return-from visit nil))
(setf (gethash u visit-map) t)
t)
)
(defun DFS(u graf)
(let ((start-time (tick)))
(append (list (list u start-time -1))
(mapcan #'(lambda(x)
(when (visit x) (DFS x graf)))
(gethash u graf))
(list (list u start-time (tick))))
))
;konstrukce hash tabulky, v ktere jsou ulozeny hrany k jednotlivym uzlum
(defun build-graf(lst)
(let ((ht (make-hash-table)))
(dolist (x lst)
(cond ((null (gethash (car x) ht)) (setf (gethash (car x) ht) (list (cdr x))))
(t (setf (gethash (car x) ht) (cons (cdr x) (gethash (car x) ht))))))
ht
))
;startovaci funkce
(defun start-DFS(lst start)
(reset-time)
;(maphash #'(lambda (k v) (format t "~a ~a~%" k v)) (build-graf lst))
(DFS start (build-graf lst))
)
;//O~P
Zadání: Napiste funkci nreverse[]
Napiste funkci nreverse bez plytvani cons bunkami tedy preretezenim seznamu.. (jak normalne ta funkce funguje) jo a samozrejme bez jejiho pouziti. Napoveda: Mno ono se to dela cyklem a sou na to potreba 3 pointery A na posledni preretezenej B na ten co se bude prehazovat a C pomocnej kterej se da na cdr B nez se B preretezi. Preretezeni pomoci setf se da nebo pomoci replacd