meteor-contest Racket program
source code
#lang racket/base
;; The Computer Language Benchmarks Game
;; http://benchmarksgame.alioth.debian.org/
;;
;; Based on a Python version:
;; contributed by Olof Kraigher
;; modified by Tupteq
;; contributed by Matthew Flatt
;; optimized by Eli Barzilay
(require racket/cmdline)
(define width 5)
(define height 10)
(define size (* width height))
(define (valid-xy? x y)
(and (0 . <= . x)
(x . < . width)
(0 . <= . y)
(y . < . height)))
(define (mover fun)
(let ([t (make-vector size)])
(for ([p (in-range size)])
(vector-set! t p (let*-values ([(y x) (quotient/remainder p width)]
[(x y) (fun x y)])
(if (valid-xy? x y) (+ x (* y width)) -1))))
t))
(define E
(mover (lambda (x y) (values (add1 x) y))))
(define W
(mover (lambda (x y) (values (sub1 x) y))))
(define NE
(mover (lambda (x y) (values (+ x (bitwise-and y 1)) (sub1 y)))))
(define NW
(mover (lambda (x y) (values (sub1 (+ x (bitwise-and y 1))) (sub1 y)))))
(define SE
(mover (lambda (x y) (values (+ x (bitwise-and y 1)) (add1 y)))))
(define SW
(mover (lambda (x y) (values (sub1 (+ x (bitwise-and y 1))) (add1 y)))))
(define rotate-list (list E NE NW W SW SE E))
(define (rotate dir)
(cadr (memq dir rotate-list)))
(define flip-alist (list (cons E W) (cons NE NW) (cons NW NE)
(cons W E) (cons SW SE) (cons SE SW)))
(define (flip dir) (cdr (assq dir flip-alist)))
(define movers (list E W NE NW SE SW))
(define (valid? p)
(p . >= . 0))
(define (clear? board pos)
(not (bitwise-bit-set? board pos)))
(define (set board pos)
(bitwise-ior board (arithmetic-shift 1 pos)))
(define (zero-count board)
(for/fold ([count 0]) ([i (in-range size)])
(if (clear? board i) (add1 count) count)))
(define (find-free-cell board)
(for/or ([p (in-range 0 size)])
(and (clear? board p) p)))
(define (flood-fill board p)
(for/fold ([board (set board p)]) ([mover (in-list movers)])
(let ([p (vector-ref mover p)])
(if (and (valid? p) (clear? board p))
(flood-fill board p)
board))))
(define (no-islands? mask)
(let ([zeros (zero-count mask)])
(and (zeros . >= . 5)
(let loop ([mask mask] [zeros zeros])
(if (= mask #x3FFFFFFFFFFFF)
#t
(let* ([p (find-free-cell mask)]
[mask (flood-fill mask p)]
[new-zeros (zero-count mask)])
(and ((- zeros new-zeros) . >= . 5)
(loop mask new-zeros))))))))
(define (get-bitmask p piece)
(let ([mask (arithmetic-shift 1 p)])
(let loop ([p p] [cells piece] [mask mask])
(if (null? cells)
mask
(let ([p (vector-ref (car cells) p)])
(and (valid? p) (loop p (cdr cells) (set mask p))))))))
(define (all-bitmasks piece color)
(let ([pieces
(let-values ([(accum piece)
(for/fold ([accum null] [piece piece])
([orientations (in-range 2)])
(let-values ([(accum piece)
(for/fold ([accum accum] [piece piece])
([orientations (in-range (- 6 (* 3 (if (= color 4) 1 0))))])
(values (cons piece accum)
(map rotate piece)))])
(values accum (map flip piece))))])
accum)])
(reverse
(for*/fold ([accum null])
([piece (in-list pieces)]
[p (in-range 0 size)])
(let ([mask (get-bitmask p piece)])
(if (and mask (no-islands? mask)) (cons mask accum) accum))))))
(define generate-bitmasks-pieces
(list (list E E E SE)
(list SE SW W SW)
(list W W SW SE)
(list E E SW SE)
(list NW W NW SE SW)
(list E E NE W)
(list NW NE NE W)
(list NE SE E NE)
(list SE SE E SE)
(list E NW NW NW)))
(define (generate-bitmasks)
(let ([masks-at-cell
(list->vector
(for/list ([i (in-range size)])
(list->vector (for/list ([j (in-range 10)]) null))))])
(for ([piece (in-list generate-bitmasks-pieces)]
[color (in-naturals)])
(let loop ([masks (sort (all-bitmasks piece color) >)]
[cell-bit (sub1 size)]
[cell-counter (sub1 size)])
(if (null? masks)
masks-at-cell
(if (bitwise-bit-set? (car masks) cell-bit)
(let ([vec (vector-ref masks-at-cell cell-counter)])
(vector-set! vec color (cons (car masks) (vector-ref vec color)))
(loop (cdr masks) cell-bit cell-counter))
(loop masks (sub1 cell-bit) (sub1 cell-counter))))))
(for ([v (in-vector masks-at-cell)])
(for ([j (in-naturals)]
[val (in-vector v)])
(vector-set! v j (reverse val))))
masks-at-cell))
(define masks-at-cell (generate-bitmasks))
(define masks (make-vector 10 0))
(define to-go 0)
(define solutions (mcons #f #f)) ; keeps (min max) solutions
(define (solve-cell! cell board)
(when (and (positive? to-go) (not (negative? cell)))
;; Need solutions and not off board
(cond [(= board #x3FFFFFFFFFFFF)
;; Solved
(add-solutions!)]
[(not (clear? board cell))
;; Cell full, so try next
(solve-cell! (sub1 cell) board)]
[else
;; Recur
(for* ([color (in-range 10)]
#:when (zero? (vector-ref masks color))
[mask (in-list (vector-ref (vector-ref masks-at-cell cell)
color))]
#:when (zero? (bitwise-and mask board)))
(vector-set! masks color mask)
(solve-cell! (sub1 cell) (bitwise-ior board mask))
(vector-set! masks color 0))])))
(define (add-solutions!)
(define (add! solution)
(cond [(not (mcar solutions))
(set-mcar! solutions solution)
(set-mcdr! solutions solution)]
[(bytes<? solution (mcar solutions))
(set-mcar! solutions solution)]
[(bytes>? solution (mcdr solutions))
(set-mcdr! solutions solution)]))
(let* ([s (list->bytes
(for/list ([pos (in-range size)])
(for/or ([color (in-range 10)])
(and (not (clear? (vector-ref masks color) pos))
(+ color (char->integer #\0))))))]
[ns (make-bytes size)])
;; Inverse
(for* ([y (in-range height)]
[x (in-range width)])
(bytes-set! ns (+ x (* y width))
(bytes-ref s (+ (- width (+ x 1))
(* width (- height (+ y 1)))))))
;; Keep first and last only
(add! s)
(add! ns)
(set! to-go (- to-go 2))))
(define (print-solution solution)
(let ([solution (bytes->string/utf-8 solution)])
(for ([y (in-range height)])
(when (odd? y) (display " "))
(for ([x (in-range width)])
(printf "~a " (string-ref solution (+ x (* y width)))))
(printf "\n"))
(newline)))
(define (solve! n)
(set! to-go n)
(solve-cell! (sub1 size) 0))
(command-line #:args (n)
(let ([n (string->number n)])
(solve! n)
(printf "~a solutions found\n\n" (- n to-go))
(print-solution (mcar solutions))
(print-solution (mcdr solutions))))
notes, command-line, and program output
NOTES:
64-bit Ubuntu quad core
Welcome to Racket v6.12.
Tue, 27 Mar 2018 22:40:19 GMT
MAKE:
/opt/src/racket-6.12/bin/raco make meteor.racket
0.63s to complete and log all make actions
COMMAND LINE:
/opt/src/racket-6.12/bin/racket ./compiled/meteor_racket.zo 2098
PROGRAM OUTPUT:
2098 solutions found
0 0 0 0 1
2 2 2 0 1
2 6 6 1 1
2 6 1 5 5
8 6 5 5 5
8 6 3 3 3
4 8 8 9 3
4 4 8 9 3
4 7 4 7 9
7 7 7 9 9
9 9 9 9 8
9 6 6 8 5
6 6 8 8 5
6 8 2 5 5
7 7 7 2 5
7 4 7 2 0
1 4 2 2 0
1 4 4 0 3
1 4 0 0 3
1 1 3 3 3