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

Switching to use data/enumerate rather than home grown

Browse Source
This commit is contained in:
Jay McCarthy 2014-11-21 13:43:20 -08:00
parent db824a3cbe
commit 8dd7a3daaf
2 changed files with 46 additions and 46 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
pkgs/games/info.rkt
View File

@ -10,7 +10,7 @@
"draw-lib" "draw-lib"
"drracket" "drracket"
"gui-lib" "gui-lib"
"net-lib" "net-lib"
"htdp-lib" "htdp-lib"
"math-lib" "math-lib"
"scribble-lib" "scribble-lib"
@ -18,6 +18,7 @@
"sgl" "sgl"
"srfi-lib" "srfi-lib"
"string-constants-lib" "string-constants-lib"
"data-enumerate-lib"
"typed-racket-lib" "typed-racket-lib"
"typed-racket-more")) "typed-racket-more"))
(define build-deps '("draw-doc" (define build-deps '("draw-doc"

89
pkgs/games/tally-maze/maze.rkt
View File

@ -1,6 +1,5 @@
#lang racket/base #lang racket/base
(require data/enumerate
(require "godel.rkt"
racket/gui/base racket/gui/base
racket/class racket/class
racket/set racket/set
@ -15,16 +14,16 @@
maze-count) maze-count)
(define (maze-count w h) (define (maze-count w h)
(spec-k (maze/s w h))) (size (maze/e w h)))
(define (decode-maze maze-w maze-h n) (define (decode-maze maze-w maze-h n)
(define mazes (maze/s maze-w maze-h)) (define mazes (maze/e maze-w maze-h))
(unless (and (exact-nonnegative-integer? n) (unless (and (exact-nonnegative-integer? n)
(< n (spec-k mazes))) (< n (size mazes)))
(raise-argument-error 'decode-maze (raise-argument-error 'decode-maze
(format "number less than ~a" (spec-k mazes)) (format "number less than ~a" (size mazes))
n)) n))
(decode mazes n)) (from-nat mazes n))
(define (memoize f) (define (memoize f)
(define ht (make-hash)) (define ht (make-hash))
@ -35,61 +34,61 @@
(hash-set! ht args (apply f args)) (hash-set! ht args (apply f args))
(hash-ref ht args))))) (hash-ref ht args)))))
(define maze/s (define maze/e
(memoize (memoize
(λ (width height) (λ (width height)
(cond (cond
[(or (= 1 height) (= 1 width)) (unit/s #f)] [(or (= 1 height) (= 1 width)) (const/e #f)]
[else [else
(k*k-bind/s (dep/e
(wrap/s (fixed-length-list/s (map/e reverse reverse
(enum/s '(l t r b)) (fixed-length-list/e
(wrap/s (nat-range/s (- height 1)) add1 sub1) (fin/e 'l 't 'r 'b)
(wrap/s (nat-range/s (- width 1)) add1 sub1)) (map/e add1 sub1 (below/e (- height 1)))
reverse reverse) (map/e add1 sub1 (below/e (- width 1)))))
(λ (ul-w/h-and-break) (λ (ul-w/h-and-break)
(define ul-w (list-ref ul-w/h-and-break 0)) (define ul-w (list-ref ul-w/h-and-break 0))
(define ul-h (list-ref ul-w/h-and-break 1)) (define ul-h (list-ref ul-w/h-and-break 1))
(define missing (list-ref ul-w/h-and-break 2)) (define missing (list-ref ul-w/h-and-break 2))
(define lr-w (- width ul-w)) (define lr-w (- width ul-w))
(define lr-h (- height ul-h)) (define lr-h (- height ul-h))
(fixed-length-list/s (fixed-length-list/e
(case missing (case missing
[(l) [(l)
(fixed-length-list/s (unit/s #f) (fixed-length-list/e (const/e #f)
(nat-range/s ul-h) (below/e ul-h)
(nat-range/s lr-w) (below/e lr-w)
(nat-range/s lr-h))] (below/e lr-h))]
[(t) [(t)
(fixed-length-list/s (nat-range/s ul-w) (fixed-length-list/e (below/e ul-w)
(unit/s #f) (const/e #f)
(nat-range/s lr-w) (below/e lr-w)
(nat-range/s lr-h))] (below/e lr-h))]
[(r) [(r)
(fixed-length-list/s (nat-range/s ul-w) (fixed-length-list/e (below/e ul-w)
(nat-range/s ul-h) (below/e ul-h)
(unit/s #f) (const/e #f)
(nat-range/s lr-h))] (below/e lr-h))]
[(b) [(b)
(fixed-length-list/s (nat-range/s ul-w) (fixed-length-list/e (below/e ul-w)
(nat-range/s ul-h) (below/e ul-h)
(nat-range/s lr-w) (below/e lr-w)
(unit/s #f))]) (const/e #f))])
(maze/s ul-w ul-h) (maze/e ul-w ul-h)
(maze/s lr-w ul-h) (maze/e lr-w ul-h)
(maze/s ul-w lr-h) (maze/e ul-w lr-h)
(maze/s lr-w lr-h))))])))) (maze/e lr-w lr-h))))]))))
(define (fixed-length-list/s . args) (define (fixed-length-list/e . args)
(let loop ([args args]) (let loop ([args args])
(cond (cond
[(null? args) (unit/s '())] [(null? args) (const/e '())]
[else (cons/s (car args) (loop (cdr args)))]))) [else (cons/e (car args) (loop (cdr args)))])))
(define (pick-a-maze maze-w maze-h) (define (pick-a-maze maze-w maze-h)
(define maze-count (spec-k (maze/s maze-w maze-h))) (define maze-count (size (maze/e maze-w maze-h)))
(+ (if (zero? (random 2)) (+ (if (zero? (random 2))
(/ maze-count 2) (/ maze-count 2)
0) 0)
@ -367,7 +366,7 @@
(module+ test (module+ test
(check-equal? (for/list ([i (in-range 1 10)]) (check-equal? (for/list ([i (in-range 1 10)])
(for/list ([j (in-range 1 10)]) (for/list ([j (in-range 1 10)])
(spec-k (maze/s i j)))) (size (maze/e i j))))
'((1 1 1 1 1 1 1 1 1) '((1 1 1 1 1 1 1 1 1)
(1 4 14 32 60 100 154 224 312) (1 4 14 32 60 100 154 224 312)
(1 14 192 1592 9088 40200 144640 442024 1187712) (1 14 192 1592 9088 40200 144640 442024 1187712)
@ -439,8 +438,8 @@
;(define maze-w 16) (define maze-h 16) ;(define maze-w 16) (define maze-h 16)
;(define maze-w 8) (define maze-h 8) ;(define maze-w 8) (define maze-h 8)
(define mazes (time (maze/s maze-w maze-h))) (define mazes (time (maze/e maze-w maze-h)))
(define maze-count (spec-k mazes)) (define maze-count (size mazes))
(printf "~a mazes\n" maze-count) (printf "~a mazes\n" maze-count)
(define slider-max-value (min maze-count 10000)) (define slider-max-value (min maze-count 10000))
@ -464,9 +463,9 @@
(define bp (new horizontal-panel% [parent f] [stretchable-height #f])) (define bp (new horizontal-panel% [parent f] [stretchable-height #f]))
(define (move-to n) (define (move-to n)
(set! which (modulo n maze-count)) (set! which (modulo n maze-count))
(set! current-edges (build-walls (decode mazes which) maze-w maze-h)) (set! current-edges (build-walls (from-nat mazes which) maze-w maze-h))
(set! current-solution (find-solution current-edges maze-w maze-h)) (set! current-solution (find-solution current-edges maze-w maze-h))
(set! next-edges (build-walls (decode mazes (modulo (+ which 1) maze-count)) (set! next-edges (build-walls (from-nat mazes (modulo (+ which 1) maze-count))
maze-w maze-h)) maze-w maze-h))
(send slider set-value (- which starting-point)) (send slider set-value (- which starting-point))
(send c refresh)) (send c refresh))