26 iunie 2010

Problema reginelor in Scheme

; Generatori de solutii si cele N regine

(define dfs
(lambda (init expand test)
(letrec ((search (lambda (border)
(cond ((null? border) '())
((test (car border)) (cons (car border)
(delay (search (cdr border)))))
(else (search (append (expand (car border))
(cdr border))))))))
(search (list init)))))

; ======= n Regine ========
; tabla de sah = ((linie_i . coloana_i) ... (linie_1 . colana_1))
; unde (linie_i . coloana_i) este pozitia reginei i pe tabla de sah

; (expand n)
; - primeste o tabla de sah cu primele i regine pozitionate corect
; - reintoarce lista tablelor de sah pe care este pozitionata regina i+1

(define expand
(lambda (n)
(lambda (board)
(let ((l (+ (length board) 1)))
(foreach (columns 1 n)
(lambda (c) (not (attack l c board)))
(lambda (c) (cons (cons l c) board)))))))

; (attack l c board)
; - primeste l c = pozitia unei noi regine
; board = o tabla de sah pe care sunt deja pozitionate corect
; reginele l-1, l-2,...1
; - reintoarce #t daca regina l este pozitionata corect

(define attack
(lambda (l c board)
(exists (lambda (queen)
(let ((lq (car queen)) (cq (cdr queen)))
(or (= c cq) (= (- l lq) (abs (- c cq))))))
board)))


; (exists p l) = #t daca in lista l exista un element care satisface predicatul p

(define exists
(lambda (p l)
(cond ((null? l) #f)
((p (car l)) #t)
(else (exists p (cdr l))))))

; (foreach set predicate fun) =
; lista tuturor elementelor din set (o lista), care satisfac predicatul pred,
; prelucrate prin fun

(define foreach
(lambda (set pred fun)
(cond ((null? set) '())
((pred (car set)) (cons (fun (car set))
(foreach (cdr set) pred fun)))
(else (foreach (cdr set) pred fun)))))

(define columns
(lambda (inf sup)
(if (> inf sup) '()
(cons inf (columns (+ 1 inf) sup)))))


(define queens
(lambda (n)
(dfs '() (expand n) (lambda (board) (= (length board) n)))))

(define hd car)
(define tl (lambda (s) (force (cdr s))))

(define take
(lambda (n s)
(if (or (zero? n) (null? s)) '()
(cons (hd s) (take (- n 1) (tl s))))))

(define drop
(lambda (n s)
(if (or (zero? n) (null? s)) s
(drop (- n 1) (tl s)))))

(define queens5 (queens 5))
(define queens8 (queens 8))


(define gen-gen
(lambda (s) ; s = fluxul solutiilor unei probleme
(lambda (n)
(let ((sols (take n s)))
(set! s (drop n s))
sols))))

(define gen-gen-queens
(lambda (gen)
(lambda (n)
(map (lambda (tabla) (map cdr tabla)) (gen n)))))

(define q5 (gen-gen queens5))
(define q5bis (gen-gen queens5))
(define q8 (gen-gen queens8))

(define qq5 (gen-gen-queens q5))

Niciun comentariu: