Click aici pentru a downloada project.scm
Click aici pentru a downloada documentatia in format .doc necomprimat.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Labirinth Generator ;
; ;;;;;;;;;;;;;;;;;;; ;
; ;
; File: project.scm ;
; ;
; Authors: ;
; * Iacob Alexandru ;
; * Neagu Marius Razvan ;
; * Patru Dragos ;
; ;
; Class: 343 & 344C4 ;
; ;
; CopyRight 2004 ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require (lib "draw.ss" "htdp"))
(define LATURA 10)
;(define SCALE 60)
(define END_TIME 5);seconds
(define STEP_TIME 10);mili-seconds
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; draw-cell: Deseneaza o celula (peretii si calea spre solutie/calea de back-tracking
(define draw-cell
(lambda (r c N W S E solN solW solS solE)
(begin
;N
(draw-solid-line (make-posn (* c LATURA) (* r LATURA))
(make-posn (+ (* c LATURA) LATURA) (* r LATURA))
(cond ((eq? N 'up) 'black) ((eq? N 'border) 'red) (else 'white))
);N
;W
(draw-solid-line (make-posn (* c LATURA) (* r LATURA))
(make-posn (* c LATURA) (+ (* r LATURA) LATURA))
(cond ((eq? W 'up) 'black) ((eq? W 'border) 'red) (else 'white))
);W
;S
(draw-solid-line (make-posn (* c LATURA) (+ (* r LATURA) LATURA))
(make-posn (+ (* c LATURA) LATURA) (+ (* r LATURA) LATURA))
(cond ((eq? S 'up) 'black) ((eq? S 'border) 'red) (else 'white))
);S
;E
(draw-solid-line (make-posn (+ (* c LATURA) LATURA) (* r LATURA))
(make-posn (+ (* c LATURA) LATURA) (+ (* r LATURA) LATURA))
(cond ((eq? E 'up) 'black) ((eq? E 'border) 'red) (else 'white))
);E
;solN
(draw-solid-line (make-posn (+ (* c LATURA) (/ LATURA 2)) (+ (* r LATURA) (/ LATURA 2)))
(make-posn (+ (* c LATURA) (/ LATURA 2)) (* r LATURA))
(cond ((eq? solN 'sol-track) 'yellow) ((eq? solN 'back-track) 'blue) (else 'white))
);solN
;solW
(draw-solid-line (make-posn (+ (* c LATURA) (/ LATURA 2)) (+ (* r LATURA) (/ LATURA 2)))
(make-posn (* c LATURA) (+ (* r LATURA) (/ LATURA 2)))
(cond ((eq? solW 'sol-track) 'yellow) ((eq? solW 'back-track) 'blue) (else 'white))
);solW
;solS
(draw-solid-line (make-posn (+ (* c LATURA) (/ LATURA 2)) (+ (* r LATURA) (/ LATURA 2)))
(make-posn (+ (* c LATURA) (/ LATURA 2)) (+ (* r LATURA) LATURA))
(cond ((eq? solS 'sol-track) 'yellow) ((eq? solS 'back-track) 'blue) (else 'white))
);solS
;solE
(draw-solid-line (make-posn (+ (* c LATURA) (/ LATURA 2)) (+ (* r LATURA) (/ LATURA 2)))
(make-posn (+ (* c LATURA) LATURA) (+ (* r LATURA) (/ LATURA 2)))
(cond ((eq? solE 'sol-track) 'yellow) ((eq? solE 'back-track) 'blue) (else 'white))
);solE
void
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; draw-labirinth: Deseneaza intregul labirint pe panza (Canvas)
(define draw-labirinth
(lambda (labirinth m n)
(let loop_row ((i 0))
(if (< i m)
(begin
(let loop_col ((j 0))
(if (< j n)
(begin
(draw-cell i j (cube-ref labirinth i j 0) (cube-ref labirinth i j 1) (cube-ref labirinth i j 2) (cube-ref labirinth i j 3)
(cube-ref labirinth i j 4) (cube-ref labirinth i j 5) (cube-ref labirinth i j 6) (cube-ref labirinth i j 7)
)
(loop_col (+ j 1))
)
#t
)
)
(loop_row (+ i 1))
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; init-graphics: initializeaza ecranul si deseneaza un labirint cu peretii sus
(define init-graphics
(lambda(m n)
(start (* n LATURA) (* m LATURA))
(let loop_row ((i 0))
(if (< i m)
(begin
(let loop_col ((j 0))
(if (< j n)
(begin
(draw-cell i j 'up 'up 'up 'up 'e 'e 'e 'e)
;(write i)
(loop_col (+ j 1))
)
#t
)
)
(loop_row (+ i 1))
)
#t
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Acces la matrici si cuburi ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(define matrix-set!
(lambda (matrix i j value)
(vector-set! (vector-ref matrix i) j value)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(define matrix-ref
(lambda (matrix i j)
(vector-ref (vector-ref matrix i) j)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(define cube-set!
(lambda (cube i j k value)
(vector-set! (vector-ref (vector-ref cube i) j) k value)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(define cube-ref
(lambda (cube i j k)
(vector-ref (vector-ref (vector-ref cube i) j) k)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
(define make-matrix
(lambda (m n)
(call/cc
(lambda(continue-with)
(begin
(define matrix (make-vector m))
(let loop ((i 0))
(if (< i m)
(begin
(vector-set! matrix i (make-vector n))
(loop (+ i 1))
)
(continue-with matrix)
);if
);let
);begin
);lambda
);call/cc
);lambda
);define
(define pick
(lambda (L index Lrest)
(if (null? L)
(list Lrest)
(if (> index 0)
(pick (cdr L) (- index 1) (append Lrest (list (car L))))
(list (car L) (append Lrest (cdr L)))
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Lucru cu matricea Labirint ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; is_isolated: verifica daca o celula e izolata
; - are nevoie de coordonate corecte!
(define is_isolated
(lambda(labirinth i j)
(not
(or
(eq? (cube-ref labirinth i j 0) 'dn)
(eq? (cube-ref labirinth i j 1) 'dn)
(eq? (cube-ref labirinth i j 2) 'dn)
(eq? (cube-ref labirinth i j 3) 'dn)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; init-labirit: initializeaza matricea labirint: peretii sus, calea spre solutie vida
(define init-labirinth
(lambda (m n params)
(call/cc
(lambda(continue-with)
(begin
(define labirinth (make-vector m))
(define labirinth_row '())
;;; Prima linie
(set! labirinth_row (make-vector n))
(vector-set! labirinth_row 0 (vector 'border 'border 'up 'up 'e 'e 'e 'e))
(let loop_col_r0 ((j 1))
(if (< j (- n 1))
(begin
(vector-set! labirinth_row j (vector 'border 'up 'up 'up 'e 'e 'e 'e))
(loop_col_r0 (+ j 1))
)
)
);let
(vector-set! labirinth_row (- n 1) (vector 'border 'up 'up 'border 'e 'e 'e 'e))
(vector-set! labirinth 0 labirinth_row)
;;; Liniile intermediare
(let loop_row ((i 1))
(if (< i (- m 1))
(begin
(set! labirinth_row (make-vector n));un nou rand
(vector-set! labirinth_row 0 (vector 'up 'border 'up 'up 'e 'e 'e 'e))
(let loop_col_g ((j 1))
(if (< j (- n 1))
(begin
(vector-set! labirinth_row j (vector 'up 'up 'up 'up 'e 'e 'e 'e))
(loop_col_g (+ j 1))
)
)
);let
(vector-set! labirinth_row (- n 1) (vector 'up 'up 'up 'border 'e 'e 'e 'e))
(vector-set! labirinth i labirinth_row)
(loop_row (+ i 1))
);begin
)
);let
;;;Ultima Linie
(set! labirinth_row (make-vector n));un nou rand
(vector-set! labirinth_row 0 (vector 'up 'border 'border 'up 'e 'e 'e 'e))
(let loop_col_last ((j 1))
(if (< j (- n 1))
(begin
(vector-set! labirinth_row j (vector 'up 'up 'border 'up 'e 'e 'e 'e))
(loop_col_last (+ j 1))
)
)
);let
(vector-set! labirinth_row (- n 1) (vector 'up 'up 'border 'border 'e 'e 'e 'e))
(vector-set! labirinth (- m 1) labirinth_row)
(continue-with labirinth)
);begin
);lambda
);call/cc
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; knock-down: darama peretele specificat (prin direction: 'N 'W 'S sau 'E) si face desenarea (g_commit = #t)
; + intoarce noua pozitie
(define knock-down
(lambda (labirinth i j direction m n g_commit)
(cond
((eq? direction 'N) (if (eq? (cube-ref labirinth i j 0) 'up)
(begin
(cube-set! labirinth i j 0 'dn)
;testul urmator nu se mai face - se considera ca matricea este consistenta (fara erori)
;(if (> i 0) (if (eq? (cube-ref labirinth (- i 1) j 2) 'up)
(cube-set! labirinth (- i 1) j 2 'dn)
(if g_commit
(draw-solid-line (make-posn (* j LATURA) (* i LATURA))
(make-posn (+ (* j LATURA) LATURA) (* i LATURA))
'white
)
)
(list (- i 1) j);returneaza noua pozitie
);begin
(list i j)
);if
);eq
((eq? direction 'W) (if (eq? (cube-ref labirinth i j 1) 'up)
(begin
(cube-set! labirinth i j 1 'dn)
;testul urmator nu se mai face - se considera ca matricea este consistenta (fara erori)
;(if (> j 0) (if (eq? (cube-ref labirinth i (- j 1) 3) 'up)
(cube-set! labirinth i (- j 1) 3 'dn)
(if g_commit
(draw-solid-line (make-posn (* j LATURA) (* i LATURA))
(make-posn (* j LATURA) (+ (* i LATURA) LATURA))
'white
)
)
(list i (- j 1));returneaza noua pozitie
);begin
(list i j)
);if
);eq
((eq? direction 'S) (if (eq? (cube-ref labirinth i j 2) 'up)
(begin
(cube-set! labirinth i j 2 'dn)
;testul urmator nu se mai face - se considera ca matricea este consistenta (fara erori)
;(if (< i (- m 1)) (if (eq? (cube-ref labirinth (+ i 1) j 0) 'up)
(cube-set! labirinth (+ i 1) j 0 'dn)
(if g_commit
(draw-solid-line (make-posn (* j LATURA) (+ (* i LATURA) LATURA))
(make-posn (+ (* j LATURA) LATURA) (+ (* i LATURA) LATURA))
'white
)
)
(list (+ i 1) j);returneaza noua pozitie
);begin
(list i j)
);if
);eq
((eq? direction 'E) (if (eq? (cube-ref labirinth i j 3) 'up)
(begin
(cube-set! labirinth i j 3 'dn)
;testul urmator nu se mai face - se considera ca matricea este consistenta (fara erori)
;(if (> j (- n 1)) (if (eq? (cube-ref labirinth i (+ j 1) 1) 'up)
(cube-set! labirinth i (+ j 1) 1 'dn)
(if g_commit
(draw-solid-line (make-posn (+ (* j LATURA) LATURA) (* i LATURA))
(make-posn (+ (* j LATURA) LATURA) (+ (* i LATURA) LATURA))
'white
)
)
(list i (+ j 1));returneaza noua pozitie
);begin
(list i j)
);if
);eq
(else (list i j))
);cond
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; generate: Genereaza labirintul conform algoritmului dat
(define generate
(lambda (algorithm m n params)
(call/cc
(lambda(continue-with)
(begin
(define labirinth 1)
(set! labirinth (init-labirinth m n params)) ;Intai initializare labirint
(algorithm labirinth (random m) (random n) m n params) ;Aplicare algoritm
(continue-with labirinth);labirinth este o referinta! deci algorithm primeste o referinta la matrice, nu toata matricea!
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; solve: Rezolva labirintul dadu-i-se pozitia de start si cea de sfarsit
; - neimplementata!
(define solve
(lambda (labirinth start_i startj goal_i goal_j m n params)
(begin
(sleep-for-a-while 1)
(print "DRAWN!")
(draw-labirinth labirinth m n)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; play: Ruleaza generarea si rezolvarea labirintului
(define play
(lambda (alghorithm m n params)
(begin
(init-graphics m n)
(let ((labirinth (generate alghorithm m n params)))
(solve labirinth (random m) (random n) (random m) (random n) m n params)
)
(sleep-for-a-while END_TIME)
(stop)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;; DFS ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; dfs_checkNorth: verifica daca poate sa darame pereti la Nord
(define dfs_checkNorth
(lambda (labirinth current_i current_j m n)
(if (> current_i 0);in interiorul matricii?
(if (is_isolated labirinth (- current_i 1) current_j);daca e izolata sigur nu fac bucle in labirint intrand in ea!
(begin
(knock-down labirinth current_i current_j 'N m n #t)
(my_dfs labirinth (- current_i 1) current_j m n)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; dfs_checkWest: verifica daca poate sa darame pereti la Vest
(define dfs_checkWest
(lambda (labirinth current_i current_j m n)
(if (> current_j 0);in interiorul matricii?
(if (is_isolated labirinth current_i (- current_j 1));daca e izolata sigur nu fac bucle in labirint intrand in ea!
(begin
(knock-down labirinth current_i current_j 'W m n #t)
(my_dfs labirinth current_i (- current_j 1) m n)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; dfs_checkSouth: verifica daca poate sa darame pereti la Sud
(define dfs_checkSouth
(lambda (labirinth current_i current_j m n)
(if (< current_i (- m 1));in interiorul matricii?
(if (is_isolated labirinth (+ current_i 1) current_j);daca e izolata sigur nu fac bucle in labirint intrand in ea!
(begin
(knock-down labirinth current_i current_j 'S m n #t)
(my_dfs labirinth (+ current_i 1) current_j m n)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; dfs_checkEast: verifica daca poate sa darame pereti la Est
(define dfs_checkEast
(lambda (labirinth current_i current_j m n)
(if (< current_j (- n 1));in interiorul matricii?
(if (is_isolated labirinth current_i (+ current_j 1));daca e izolata sigur nu fac bucle in labirint intrand in ea!
(begin
(knock-down labirinth current_i current_j 'E m n #t)
(my_dfs labirinth current_i (+ current_j 1) m n)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; my_dfs: alege aleator directiile cardinale si construieste labirintul recursiv
(define my_dfs
(lambda(labirinth current_i current_j m n)
(begin ;exemplu check_list: (dfs_checkSouth (dfs_checkNorth dfs_checkWest dfs_checkEast))
(let loop ((check_list (pick (list dfs_checkNorth dfs_checkWest dfs_checkSouth dfs_checkEast) (random 4) '())) (i 3))
(begin
((car check_list) labirinth current_i current_j m n); execut procedura aleasa aleator
(if (> i 0);daca lista de 'directii' nu e vida
(loop (pick (cadr check_list) (random i) '()) (- i 1)); trec mai departe si aleg alta directie random
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;dfs: infasuratoare pentru my_dfs pentru a suporta forma generalizata de algoritm pentru generare labirint :D
(define dfs
(lambda(labirinth current_i current_j m n params)
(my_dfs labirinth current_i current_j m n)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;; Eller's Algorithm ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;fill-ncremented-vector: initializeaza un vector in fiecare locatie cu indexul locatiei inceepand de la offset
(define fill-incremented-vector
(lambda(v offset limit)
(if (< offset limit)
(begin
(vector-set! v offset offset)
(fill-incremented-vector v (+ offset 1) limit)
v
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; propagate-sets: in vectorul row, daca se intalneste valoarea din value2 se inlocuieste cu value1
; + astfel daca value1 reprezinta multimea 5 si value2 reprezinta multimea 7, iar in algoritmul lui Eller
; + s-a creeat un pasaj intre cele 2 multimi (5 si 7) reunirea lor va fi multimea notata cu 5!
(define propagate-sets
(lambda (row value1 value2 n)
(let loop((col 0))
(if (< col n)
(begin
(if (eq? (vector-ref row col) value2)
(vector-set! row col value1);unde dam de multimea 2 punem 1
)
(loop (+ col 1))
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ellers_choose_horizontally: la generarea unui rad nou in labirint, genereaza pasaje (legaturi) orizontale aleator
(define ellers_choose_horizontally
(lambda (row labirinth row_number priority m n)
(let loop ((col 0))
(if (< col (- n 1)) ;scanam pana la penultima coloana
(if (not (eq? (vector-ref row col) (vector-ref row (+ col 1))));multimi diferite
(if (> (random 100) priority);dam jos perete pe orizontala? - aici poate fi o fct de random care depinde si de coloana sau rand
(begin
(knock-down labirinth row_number col 'E m n #t);daram peretele
(propagate-sets row (vector-ref row col) (vector-ref row (+ col 1)) n);reunesc multimile
(loop (+ col 1));urmatoarea coloana
)
(loop (+ col 1))
)
(loop (+ col 1))
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ellers_choose_vertically: la generarea unui rad nou in labirint, genereaza pasaje (legaturi) verticale aleator
; + de fapt genereaza urmatorul rand!
(define ellers_choose_vertically
(lambda (row labirinth row_number max_set priority m n)
(let loop ((col 0))
(if (< col n);scanam TOATE coloanele
(if (> (random 100) priority);dam jos perete pe verticala?
(begin
(knock-down labirinth row_number col 'S m n #t);doar atat! valoarea din row ramane aceeasi (aceeasi multime)
(loop (+ col 1));urmatoarea coloana
)
(begin
(vector-set! row col (vector-ref max_set 0));celula (probabil) izolata => are propria multime - propriul numar de ordine
(vector-set! max_set 0 (+ (vector-ref max_set 0) 1));pentru a beneficia de un nou numar de ordine!
(loop (+ col 1))
)
)
row;s-a terminat scanarea => returnam randul pentru a fi prelucrat mai departe
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; horiz_priority: extrage priorirtatea pe orizontala din lista de parametri, daca este posibil; daca nu returneaza valori implicite
(define horiz_priority
(lambda(params)
(if (null? params)
50
(if (list? params)
(if (number? (car params))
(car params)
50
)
(if (number? params)
params
50
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; vert_priority: extrage priorirtatea pe verticala din lista de parametri, daca este posibil; daca nu returneaza valori implicite
(define vert_priority
(lambda(params)
(if (null? params)
50
(if (list? params)
(if (number? (cadr params))
(cadr params)
50
)
(if (number? params)
params
50
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ellers: implementeaza algoritmul lui Eller
(define ellers
(lambda(labirinth dummy1 dummy2 m n params)
(let loop ((row (fill-incremented-vector (make-vector n) 0 n)) (row_number 0) (max_set (vector n)));initial fiecare celula e in multimea ei (0 1 2 ...)
(if (< row_number (- n 1));in afara de ultimul rand
(begin
(ellers_choose_horizontally row labirinth row_number (horiz_priority params) m n);fac pasaje orizontale
(loop (ellers_choose_vertically row labirinth row_number max_set (vert_priority params) m n) (+ row_number 1) max_set);apoi verticale
)
(let loop ((col 0));pentru ultimul rand trebuie sa fac neaparat pasaje intre celulele adiacente astfel incat toate multimile sa se reuneasca
(if (< col (- n 1))
(if (not (eq? (vector-ref row col) (vector-ref row (+ col 1))));in multimi diferite?
(begin
(knock-down labirinth row_number col 'E m n #t);daram peretele
(propagate-sets row (vector-ref row col) (vector-ref row (+ col 1)) n);reunesc cele 2 multimi
)
)
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;; Hunt and Kill ;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; stupidity-length: extrage primul parametru dintr-o lista de parametri, avand valori implicite in caz de eroare
(define stupidity-length
(lambda(params)
(if (null? params)
5
(if (list? params)
(if (number? (car params))
(car params)
5
)
(if (number? params)
params
5
)
)
)
)
)
(define directions (vector 'N 'W 'S 'E))
(define h_ofs (vector 0 -1 0 +1))
(define v_ofs (vector -1 0 +1 0))
(define get_i car)
(define get_j cadr)
(define % modulo)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; carve: functie care la fiecare iteratie darama cate un perete fara sa faca bucle (numai celule izolate)
(define carve
(lambda (labirinth start_i start_j m n stupidity)
(let loop ((pos (list start_i start_j)) (nwalls (- (* m n) 1)) (from_dir (random 4))); pos = pozitia curenta de forma (linia coloana)
(let loop_dir ((dir_list (pick '(0 1 2 3) (% (+ from_dir 2) 4) '())) (ndir 3));incerc pana gasesc o directie cu o celula izolata
(if (not (eq? (cube-ref labirinth (get_i pos) (get_j pos) (car dir_list)) 'border));am voie in directia respectiva? (bordura?)
(if (is_isolated labirinth
(+ (get_i pos) (vector-ref v_ofs (car dir_list))) ;calculez linia conform directiei in care vreau sa escavez
(+ (get_j pos) (vector-ref h_ofs (car dir_list))) ;calculez coloana conform directiei in care vreau sa escavez
);can carve it?
;atunci trec la iteratia urmatoare, nu inainte de a darama peretele ca sa ajung in cel. izolata; vvv-->inca un perete daramat
(loop (knock-down labirinth (get_i pos) (get_j pos) (vector-ref directions (car dir_list)) m n #t) (- nwalls 1) (car dir_list))
;altfel ori incerc alta directie ori trec pe hunt mode...
(if (> ndir 0);mai am directii de incercat?
(loop_dir (pick (cadr dir_list) (random ndir) '()) (- ndir 1))
(if (> nwalls 0)
(loop (hunt labirinth pos (* m n) (% (+ from_dir 2) 4) stupidity) nwalls (random 4));caut o celula cu una adiacenta si izol
;^^^--> hunt backwards the first tried direction
)
)
)
(if (> ndir 0);mai am directii de incercat?
(loop_dir (pick (cadr dir_list) (random ndir) '()) (- ndir 1))
(if (> nwalls 0)
(loop (hunt labirinth pos (* m n) (% (+ from_dir 2) 4) stupidity) nwalls (random 4))
)
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; get-direction: returneaza directia DINSPRE care se intra in current_po din last_pos
(define get-direction ;se prespune ca celulele sunt adiacente; daca nu sunt adiacente rezultatul este corect intai pe verticala apoi pe orizontala!
(lambda (current_pos last_pos)
(if (< (get_i current_pos) (get_i last_pos));dinspre sud
2
(if (> (get_i current_pos) (get_i last_pos));dinspre nord
0
(if (< (get_j current_pos) (get_j last_pos));dinspre est
3
(if (> (get_j current_pos) (get_j last_pos));dinspre vest
1
0;implicit se considera ca vin dinspre nord (current_pos == last_pos)
)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; right-hand: daca i se da o celula neizolata, cauta o iesire din celula dupa regula mainii drepte
(define right-hand
(lambda (labirinth current_pos last_pos)
(let loop ((dir (% (+ (get-direction current_pos last_pos) 1) 4)) (ndir 0))
;^^^-->prima directie este la dreapta fata de cum am sosit in celula
(if (eq? (cube-ref labirinth (get_i current_pos) (get_j current_pos) dir) 'dn);drum liber
(list (+ (get_i current_pos) (vector-ref v_ofs dir)) (+ (get_j current_pos) (vector-ref h_ofs dir)))
(if (< ndir 3);daca nu am gasit pasaj trec la urmatoarea directie tinand mana dreapta pe perete! => (++ la directie) modulo 4
(loop (% (+ dir 1) 4) (+ ndir 1))
current_pos;nu am gasit o directie libera! (cand curent_pos este o celula isolata! iar last_pos e aiurea,probabil,chiar daca e adiacenta)
)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; hunt: cauta dupa regula mainii drepte o celula care are alta adiacenta izolata
(define hunt
(lambda (labirinth pos ntotalcells from_dir stupidity)
(let loop ((pos pos) (stop (* 2 ntotalcells)) (last_pos pos));fiind labirint perfect nu se poate trece de mai mult de 2 ori
;prin aceeasi celula folosind regula mainii drepte
(if (> stop 0)
(let loop_testdir ((testdir 0));testez cele 4 directii! daca am gasit o celula izolata, atunci celula curenta este un scop atins!
(if (not (eq? (cube-ref labirinth (get_i pos) (get_j pos) testdir) 'border));am voie in directia respectiva? (bordura?)
(if (is_isolated labirinth (+ (get_i pos) (vector-ref v_ofs testdir)) (+ (get_j pos) (vector-ref h_ofs testdir)));isolated?
pos;returnez positia curenta (in vecinatatea unei celule izolate)
(if (< testdir 3)
(loop_testdir (+ testdir 1));incearca urmatoarea directie
(loop (right-hand labirinth pos last_pos) (- stop 1) pos);deplaseare intr-o noua celula dupa regula mainii drepte
)
)
(if (< testdir 3)
(loop_testdir (+ testdir 1))
(loop (right-hand labirinth pos last_pos) (- stop 1) pos);go next cell by rigth-hand rule
)
)
)
pos;ultima pozitie incercata (pentru care ar trebui sa gasesc o vecinatate izolata)
)
)
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; hunt-kill: infasuratoare pentru carve, pentru a pastra forma generalizata a funtiei pentru generarea labirintului
(define hunt-kill
(lambda(labirinth current_i current_j m n params)
(carve labirinth current_i current_j m n (stupidity-length params))
)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;; PLAY ;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;LET's PLAY SOME!
(play dfs 50 50 '())
(play ellers 50 50 '(10 50))
(play hunt-kill 50 50 '())
;SSSSMOKIN'!!! ain't it?
void
|
