parrallel2.rkt

#lang racket

(provide main)

; Represent a position as a struct with x (file) and y (rank) members
(struct pos (x y) #:prefab)

; Indicate whether q1 is attacking q2
(define (is-attacking? q1 q2)
  (let ([q1x (pos-x q1)] [q1y (pos-y q1)] [q2x (pos-x q2)] [q2y (pos-y q2)])
    (or (= q1y q2y)
        (= (abs (- q1y q2y))
           (abs (- q1x q2x))))))

; Indicate whether the stack of positions is valid
(define (valid? stack)
  (not (ormap (curry is-attacking? (car stack)) (cdr stack))))

; Return a stack representing the next position, or #f if none exist
(define (next-position n stack)
  (cond [ (null? stack) #f ]
        [ else (match-define (pos x y) (car stack))
              (if (< y n)
                  (cons (pos x (+ y 1)) (cdr stack))
                  (next-position n (cdr stack))) ]))

; Accept a board size and partial list of moves, and return
; the next solution if one exists, or #f if not
(define (queens n stack)
  (let loop ([stack stack])
    (match-define (pos x y) (car stack))
    (cond [ (> x n) (cdr stack)                                ] ; Return solution
          [ (valid? stack) (loop (cons (pos (+ x 1) 1) stack)) ] ; Go to next file
          [ (< y n) (loop (cons (pos x (+ y 1)) (cdr stack)))  ] ; Go to next rank
          [ else (let ([next (next-position n (cdr stack))])     ; Backtrack
                  (if next (loop next) #f))                    ])))

(define (prefix-matches? prefix stack)
  (let ([plen (length prefix)]
        [slen (length stack)])
    (and (>= slen plen)
         (equal? prefix (take-right stack plen)))))

; Accept a partial list of moves (prefix), and return a list of solutions with the same prefix.
(define (solutions-for-prefix n prefix)
  (let loop ([solution (queens n prefix)] [solutions '()])
    (if (and solution (prefix-matches? prefix solution))
      (let ([stack (next-position n solution)])
        (if stack ; Also verify stack matches prefix?
            (loop (queens n stack) (cons solution solutions))
            (cons solution solutions)))
      solutions)))

(define (main)
  (define n 13)
  (define num-solutions 73712)
  (define-values (parent child) (place-channel))

  ; Create worker places
  (for ([i '(1 2 3 4)])
       (define p
         (place ch
                (define n (place-channel-get ch))
                (define queue (place-channel-get ch))
                (let loop ([prefix (place-channel-get queue)])
                  (let ([solutions (solutions-for-prefix n prefix)])
                    (when (not (null? solutions))
                      (place-channel-put queue solutions)))
                  (loop (place-channel-get queue)))))
       
       (place-channel-put p n)
       (place-channel-put p child))

  (for ([i (in-range 1 (+ n 1) 1)])
       (place-channel-put parent (list (pos 1 i))))

  (define solutions (place-channel-get parent))
  (define count (length solutions))
  (let loop ([solutions solutions])
    (if (< count num-solutions)
        (let ([result (place-channel-get parent)])
          (set! count (+ count (length result)))
          (loop (append result solutions)))
        count)))