suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

optimizations: use vectors instead of move-procs, avoid mapping symbols, tighten loops, use bytes, keep only min+max solutions etc

Browse Source 
svn: r11624
This commit is contained in:
Eli Barzilay 2008-09-10 00:52:11 +00:00
parent 9c928f7e82
commit bb470554a5
1 changed files with 150 additions and 165 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

261
collects/tests/mzscheme/benchmarks/shootout/meteor.ss
View File

@ -4,105 +4,95 @@
;; Based on a Python version: ;; Based on a Python version:
;; contributed by Olof Kraigher ;; contributed by Olof Kraigher
;; modified by Tupteq ;; modified by Tupteq
;; contributed by Matthew Flatt
;; optimized by Eli Barzilay
#lang scheme/base #lang scheme/base
(require scheme/cmdline) (require scheme/cmdline scheme/list)
(define width 5) (define width 5)
(define height 10) (define height 10)
(define size (* width height))
(define (rotate dir) (define (valid-xy? x y)
(case dir
[(E) 'NE]
[(NE) 'NW]
[(NW) 'W]
[(W) 'SW]
[(SW) 'SE]
[(SE) 'E]))
(define (flip dir)
(case dir
[(E) 'W]
[(NE) 'NW]
[(NW) 'NE]
[(W) 'E]
[(SW) 'SE]
[(SE) 'SW]))
(define move
(make-immutable-hash
(list
(cons 'E (lambda (x y) (values (add1 x) y)))
(cons 'W (lambda (x y) (values (sub1 x) y)))
(cons 'NE (lambda (x y) (values (+ x (bitwise-and y 1)) (sub1 y))))
(cons 'NW (lambda (x y) (values (sub1 (+ x (bitwise-and y 1))) (sub1 y))))
(cons 'SE (lambda (x y) (values (+ x (bitwise-and y 1)) (add1 y))))
(cons 'SW (lambda (x y) (values (sub1 (+ x (bitwise-and y 1))) (add1 y)))))))
(define move-procs
(hash-map move (lambda (k v) v)))
(define (valid? x y)
(and (0 . <= . x) (and (0 . <= . x)
(x . < . width) (x . < . width)
(0 . <= . y) (0 . <= . y)
(y . < . height))) (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) (define (clear? board pos)
(not (bitwise-bit-set? board pos))) (not (bitwise-bit-set? board pos)))
(define (set board pos) (define (set board pos)
(bitwise-ior board (arithmetic-shift 1 pos))) (bitwise-ior board (arithmetic-shift 1 pos)))
(define (zero-count board) (define (zero-count board)
(for/fold ([count 0]) (for/fold ([count 0]) ([i (in-range size)])
([i (in-range (* width height))]) (if (clear? board i) (add1 count) count)))
(if (clear? board i)
(add1 count)
count)))
(define (find-free-cell board) (define (find-free-cell board)
(let yloop ([y 0]) (for/or ([p (in-range 0 size)])
(let xloop ([x 0]) (and (clear? board p) p)))
(if (= x width)
(yloop (add1 y))
(if (clear? board (+ x (* width y)))
(values x y)
(xloop (add1 x)))))))
(define (flood-fill board x y) (define (flood-fill board p)
(if (valid? x y) (for/fold ([board (set board p)]) ([mover (in-list movers)])
(let ([pos (+ x (* y width))]) (let ([p (vector-ref mover p)])
(if (clear? board pos) (if (and (valid? p) (clear? board p))
(for/fold ([board (set board pos)]) (flood-fill board p)
([move-proc move-procs]) board))))
(let-values ([(x y) (move-proc x y)])
(flood-fill board x y)))
board))
board))
(define (no-islands? mask) (define (no-islands? mask)
(let ([zeros (zero-count mask)]) (let ([zeros (zero-count mask)])
(if (zeros . < . 5) (and (zeros . >= . 5)
#f (let loop ([mask mask] [zeros zeros])
(let loop ([mask mask][zeros zeros])
(if (= mask #x3FFFFFFFFFFFF) (if (= mask #x3FFFFFFFFFFFF)
#t #t
(let*-values ([(x y) (find-free-cell mask)] (let* ([p (find-free-cell mask)]
[(mask) (flood-fill mask x y)] [mask (flood-fill mask p)]
[(new-zeros) (zero-count mask)]) [new-zeros (zero-count mask)])
(if ((- zeros new-zeros) . < . 5) (and ((- zeros new-zeros) . >= . 5)
#f
(loop mask new-zeros)))))))) (loop mask new-zeros))))))))
(define (get-bitmask x y piece) (define (get-bitmask p piece)
(let ([mask (arithmetic-shift 1 (+ x (* y width)))]) (let ([mask (arithmetic-shift 1 p)])
(let loop ([x x][y y][cells piece][mask mask]) (let loop ([p p] [cells piece] [mask mask])
(if (null? cells) (if (null? cells)
mask mask
(let-values ([(x y) ((hash-ref move (car cells)) x y)]) (let ([p (vector-ref (car cells) p)])
(if (valid? x y) (and (valid? p) (loop p (cdr cells) (set mask p))))))))
(loop x y (cdr cells) (set mask (+ x (* width y))))
#f))))))
(define (all-bitmasks piece color) (define (all-bitmasks piece color)
(let ([pieces (let ([pieces
@ -111,43 +101,39 @@
([orientations (in-range 2)]) ([orientations (in-range 2)])
(let-values ([(accum piece) (let-values ([(accum piece)
(for/fold ([accum accum] [piece piece]) (for/fold ([accum accum] [piece piece])
([orientations (in-range (- 6 (* 3 (if (= color 4) ([orientations (in-range (- 6 (* 3 (if (= color 4) 1 0))))])
1
0))))])
(values (cons piece accum) (values (cons piece accum)
(map rotate piece)))]) (map rotate piece)))])
(values accum (map flip piece))))]) (values accum (map flip piece))))])
accum)]) accum)])
(for*/list ([piece (in-list pieces)] (reverse
[y (in-range height)] (for*/fold ([accum null])
[x (in-range width)] ([piece (in-list pieces)]
[mask (:do-in ([(mask) (get-bitmask x y piece)]) ; should be in-value [p (in-range 0 size)])
#t () #t () #t #f ())] (let ([mask (get-bitmask p piece)])
#:when (and mask (no-islands? mask))) (if (and mask (no-islands? mask)) (cons mask accum) accum))))))
mask)))
(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) (define (generate-bitmasks)
(let ([pieces '((E E E SE) (let ([masks-at-cell
(SE SW W SW)
(W W SW SE)
(E E SW SE)
(NW W NW SE SW)
(E E NE W)
(NW NE NE W)
(NE SE E NE)
(SE SE E SE)
(E NW NW NW))]
[masks-at-cell
(list->vector (list->vector
(for/list ([i (in-range (* width height))]) (for/list ([i (in-range size)])
(list->vector (list->vector (for/list ([j (in-range 10)]) null))))])
(for/list ([j (in-range 10)]) (for ([piece (in-list generate-bitmasks-pieces)]
null))))])
(for ([piece (in-list pieces)]
[color (in-naturals)]) [color (in-naturals)])
(let loop ([masks (sort (all-bitmasks piece color) >)] (let loop ([masks (sort (all-bitmasks piece color) >)]
[cell-bit (sub1 (* width height))] [cell-bit (sub1 size)]
[cell-counter (sub1 (* width height))]) [cell-counter (sub1 size)])
(if (null? masks) (if (null? masks)
masks-at-cell masks-at-cell
(if (bitwise-bit-set? (car masks) cell-bit) (if (bitwise-bit-set? (car masks) cell-bit)
@ -165,14 +151,12 @@
(define masks (make-vector 10 0)) (define masks (make-vector 10 0))
(define to-go 0) (define to-go 0)
(define solutions null) (define solutions (mcons #f #f)) ; keeps (min max) solutions
(define (solve-cell! cell board) (define (solve-cell! cell board)
(when (and (positive? to-go) (when (and (positive? to-go) (not (negative? cell)))
(not (negative? cell)))
;; Need solutions and not off board ;; Need solutions and not off board
(cond (cond [(= board #x3FFFFFFFFFFFF)
[(= board #x3FFFFFFFFFFFF)
;; Solved ;; Solved
(add-solutions!)] (add-solutions!)]
[(not (clear? board cell)) [(not (clear? board cell))
@ -180,56 +164,57 @@
(solve-cell! (sub1 cell) board)] (solve-cell! (sub1 cell) board)]
[else [else
;; Recur ;; Recur
(for ([color (in-range 10)]) (for* ([color (in-range 10)]
(when (zero? (vector-ref masks color)) #:when (zero? (vector-ref masks color))
(for ([mask (in-list (vector-ref [mask (in-list (vector-ref (vector-ref masks-at-cell cell)
(vector-ref masks-at-cell cell) color))]
color))]) #:when (zero? (bitwise-and mask board)))
(when (zero? (bitwise-and mask board))
(vector-set! masks color mask) (vector-set! masks color mask)
(solve-cell! (sub1 cell) (bitwise-ior board mask)) (solve-cell! (sub1 cell) (bitwise-ior board mask))
(vector-set! masks color 0)))))]))) (vector-set! masks color 0))])))
(define (add-solutions!) (define (add-solutions!)
(let ([digits (define (add! solution)
(for/list ([pos (in-range (* width height))]) (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)]) (for/or ([color (in-range 10)])
(and (not (clear? (vector-ref masks color) pos)) (and (not (clear? (vector-ref masks color) pos))
color)))]) (+ color (char->integer #\0))))))]
(let ([s (list->string [ns (make-bytes size)])
(map (lambda (digit)
(if digit
(integer->char (+ digit (char->integer #\0)))
#\.))
digits))]
[ns (make-string (* width height))])
;; Inverse ;; Inverse
(for* ([y (in-range height)] (for* ([y (in-range height)]
[x (in-range width)]) [x (in-range width)])
(string-set! ns (+ x (* y width)) (bytes-set! ns (+ x (* y width))
(string-ref s (+ (- width (+ x 1)) (bytes-ref s (+ (- width (+ x 1))
(* width (- height (+ y 1))))))) (* width (- height (+ y 1)))))))
;; Append ;; Keep first and last only
(set! solutions (cons s solutions)) (add! s)
(set! solutions (cons ns solutions)) (add! ns)
(set! to-go (- to-go 2))))) (set! to-go (- to-go 2))))
(define (print-solution solution) (define (print-solution solution)
(let ([solution (bytes->string/utf-8 solution)])
(for ([y (in-range height)]) (for ([y (in-range height)])
(when (odd? y) (display " "))
(for ([x (in-range width)]) (for ([x (in-range width)])
(display (string-ref solution (+ x (* y width)))) (printf "~a " (string-ref solution (+ x (* y width)))))
(display " ")) (printf "\n"))
(display "\n") (newline)))
(when (even? y)
(display " ")))
(newline))
(define (solve! n) (define (solve! n)
(set! to-go n) (set! to-go n)
(solve-cell! (sub1 (* width height)) 0)) (solve-cell! (sub1 size) 0))
(command-line #:args (n) (solve! (string->number n))) (command-line #:args (n)
(let ([solutions (sort solutions string<?)]) (let ([n (string->number n)])
(printf "~a solutions found\n\n" (length solutions)) (solve! n)
(print-solution (car solutions)) (printf "~a solutions found\n\n" (- n to-go))
(print-solution (list-ref solutions (sub1 (length solutions))))) (print-solution (mcar solutions))
(print-solution (mcdr solutions))))