├── res ├── w.ico ├── bump.wav ├── door.wav ├── img.png ├── w.icns ├── zap.wav ├── bump2.wav ├── locked.wav ├── screen.wav ├── solve.wav ├── gameover.wav ├── gamestart.wav ├── newroom.wav ├── screen2.wav └── slowtele.wav ├── README.org ├── source ├── core.rkt ├── w.rkt ├── sound.rkt ├── utils.rkt ├── gui.rkt ├── render.rkt ├── player.rkt ├── tile.rkt ├── game.rkt └── level.rkt └── LICENSE /res/w.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/w.ico -------------------------------------------------------------------------------- /res/bump.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/bump.wav -------------------------------------------------------------------------------- /res/door.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/door.wav -------------------------------------------------------------------------------- /res/img.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/img.png -------------------------------------------------------------------------------- /res/w.icns: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/w.icns -------------------------------------------------------------------------------- /res/zap.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/zap.wav -------------------------------------------------------------------------------- /res/bump2.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/bump2.wav -------------------------------------------------------------------------------- /res/locked.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/locked.wav -------------------------------------------------------------------------------- /res/screen.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/screen.wav -------------------------------------------------------------------------------- /res/solve.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/solve.wav -------------------------------------------------------------------------------- /res/gameover.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/gameover.wav -------------------------------------------------------------------------------- /res/gamestart.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/gamestart.wav -------------------------------------------------------------------------------- /res/newroom.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/newroom.wav -------------------------------------------------------------------------------- /res/screen2.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/screen2.wav -------------------------------------------------------------------------------- /res/slowtele.wav: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/thomcc/W/HEAD/res/slowtele.wav -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * W 2 | W was created as my entry into [[http://www.ludumdare.com/compo/][Ludum Dare Jam 22]] (See [[https://github.com/thomcc/W/downloads][downloads]] 3 | or [[https://github.com/thomcc/W/tree/ldjam][this branch]] for what I submitted, the entry itself is located 4 | [[http://www.ludumdare.com/compo/ludum-dare-22/?action=preview&uid=7728][here]]). 5 | 6 | I have changed it since then, however I'm no longer working on 7 | it. 8 | -------------------------------------------------------------------------------- /source/core.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base) 3 | (provide (all-defined-out)) 4 | 5 | (define *width* 800) 6 | (define *height* 480) 7 | 8 | (define TILES_WIDE 10) 9 | (define TILES_HIGH 6) 10 | (define TILE_SIZE 16) 11 | (define PIX_WIDE (* TILES_WIDE TILE_SIZE)) 12 | (define PIX_HIGH (* TILES_HIGH TILE_SIZE)) 13 | (define ASPECT_RATIO (/ PIX_WIDE PIX_HIGH)) 14 | (define *scale* (/ *width* PIX_WIDE)) 15 | 16 | (define *magenta-is-transparent* (make-parameter #t)) 17 | (define *debug* (make-parameter #f)) 18 | (define *game-name* (make-parameter "")) 19 | -------------------------------------------------------------------------------- /source/w.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | "gui.rkt" 5 | "utils.rkt" 6 | "core.rkt") 7 | 8 | 9 | (define (make-solid-bitmap w h col) 10 | (let ((b (make-bitmap w h))) 11 | (send* (new bitmap-dc% [bitmap b]) 12 | (set-background col) 13 | (clear)) 14 | b)) 15 | 16 | (define (main) 17 | (*debug* #t) 18 | (*game-name* "W") 19 | (*magenta-is-transparent* #f) 20 | (define semaphore (make-semaphore 0)) 21 | 22 | (define frame 23 | (make-object 24 | (class frame% 25 | (define/augment (on-close) 26 | (semaphore-post semaphore) 27 | (inner (void) on-close)) 28 | (super-new)) (*game-name*))) 29 | 30 | (define w-canvas (make-object w-canvas% frame)) 31 | 32 | (send* frame 33 | (min-width *width*) 34 | (min-height *height*) 35 | (show #t)) 36 | 37 | (when (*debug*) 38 | (let ((bblit (make-solid-bitmap 16 16 "blue")) 39 | (wblit (make-solid-bitmap 16 16 "white"))) 40 | (register-collecting-blit w-canvas 2 2 16 16 bblit wblit))) 41 | 42 | (send w-canvas start) 43 | (void (yield semaphore)) 44 | (send w-canvas stop)) 45 | 46 | (main) 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /source/sound.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base racket/runtime-path "utils.rkt") 3 | (define-runtime-path bump "../res/bump.wav") 4 | (define-runtime-path door "../res/door.wav") 5 | (define-runtime-path game-over "../res/gameover.wav") 6 | (define-runtime-path game-start "../res/gamestart.wav") 7 | (define-runtime-path screen "../res/screen.wav") 8 | (define-runtime-path zap "../res/zap.wav") 9 | (define-runtime-path solve "../res/solve.wav") 10 | (define-runtime-path locked "../res/locked.wav") 11 | (define (get-sound s) 12 | (case s 13 | [(zap) zap] 14 | [(bump) bump] 15 | [(game-start start-game new-game) game-start] 16 | [(game-over) game-over] 17 | [(screen) screen] 18 | [(door) door] 19 | [(locked) locked] 20 | [(solve win new-level) solve] 21 | [else (printf "couldn't find sound: ~a~n" s) #f])) 22 | (provide play-effect play-effects) 23 | (define (play-effects elist) 24 | (for-each play-effect elist)) 25 | (define (play-effect effectname [async? #t]) 26 | (let ((fxp (get-sound effectname)));(alist-get effectname sounds-alist (λ _ (printf "couldnt find sound: ~a~n" effectname) #f)))) 27 | (when fxp 28 | (play-sound fxp async?)))) -------------------------------------------------------------------------------- /source/utils.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (provide (all-defined-out)) 4 | 5 | 6 | #;(define (replace-all list replacements) 7 | (map (λ (e) (let ((a (assoc e replacements))) 8 | (if a (cdr a) e))) list)) 9 | (define (ensure-list x) (if (list? x) x (list x))) 10 | (define (alist-get x alist [otherwise (λ _ #f)]) 11 | (let ((e (assoc x alist))) (if e (cdr e) (otherwise x)))) 12 | (define (pt+ p1 p2) 13 | (cons (+ (car p1) (car p2)) 14 | (+ (cdr p1) (cdr p2)))) 15 | 16 | (define vref 17 | (case-lambda 18 | ((v x) (vector-ref v x)) 19 | ((v y x) (vector-ref (vector-ref v y) x)))) 20 | 21 | (define vset! 22 | (case-lambda 23 | ((v x val) (vector-set! v x val)) 24 | ((v y x val) (vector-set! (vector-ref v y) x val)))) 25 | 26 | (define-syntax-rule (push! l x) 27 | (begin 28 | (set! l (cons x l)) 29 | l)) 30 | 31 | (define-syntax-rule (pop! l) 32 | (let ((v (car l))) 33 | (set! l (cdr l)) 34 | v)) 35 | (define (random-boolean [one-in-chance 2]) 36 | (zero? (random one-in-chance))) 37 | (define-syntax-rule (remove-from-list! l item) 38 | (begin 39 | (set! l (remove item l)) 40 | l)) 41 | (define (!= . args) 42 | (not (apply = args))) 43 | (define (pt=? a b) 44 | (and (= (car a) (car b)) 45 | (= (cdr a) (cdr b)))) 46 | (define (pt->values p) ; ugh i should probably make these structs 47 | (values (car p) (cdr p))) 48 | (define values->pt cons) ; for symmetry, even if it is dumb 49 | (define (pt-mod p m) 50 | (cons (modulo (car p) (car m)) 51 | (modulo (cdr p) (cdr m)))) 52 | (define-syntax-rule (inc! x v) (set! x (+ x v))) 53 | (define-syntax-rule (dec! x v) (set! x (- x v))) 54 | 55 | (define (floor* x [d 1]) (inexact->exact (floor (/ x d)))) 56 | 57 | (define (round* x) (inexact->exact (round x))) 58 | 59 | (define (random-element lst) 60 | (list-ref lst (random (length lst)))) 61 | (define (clamp x min max) 62 | (cond [(< x min) min] [(> x max) max] [#t x])) 63 | 64 | 65 | (define (exit-dir x y) 66 | ;(let ([x0? (<= x 0)] [x9? (>= x 9)] 67 | ; [y0? (<= y 0)] [y5? (>= y 5)]) 68 | ; (cond [(and x0? y0?) 69 | (cond [(= x 0) 'left] [(>= x 9) 'right] [(= y 0) 'up] [(>= y 5) 'down] [else (printf "dont know what to do for ~a, ~a~n" x y) 'up])) 70 | 71 | (define (get-delta dir) 72 | (alist-get dir '((up . (0 . -1)) 73 | (down . (0 . +1)) 74 | (left . (-1 . 0)) 75 | (right . (+1 . 0))))) 76 | 77 | (define (opposite dir) 78 | (case dir 79 | [(up) 'down] 80 | [(down) 'up] 81 | [(left) 'right] 82 | [(right) 'left] 83 | [else (error 'opposite "not a direction! ~a" dir)])) 84 | 85 | (define (wrap-around x y [xoff 0] [yoff 0]) 86 | (define-values ( xmax ymax) (values 10 6)) 87 | (let ((d (get-delta (exit-dir x y) #;(opposite (exit-dir x y))))) 88 | (pt->values (pt-mod (pt+ (cons x y) d) (cons xmax ymax))))) 89 | 90 | (define-syntax when-let 91 | (syntax-rules () 92 | [(_ ((var val) . rest) body ...) 93 | (let ((var val)) 94 | (when var 95 | (let rest 96 | body ...)))])) 97 | 98 | (define-syntax unless-let 99 | (syntax-rules () 100 | [(_ ((var val) . rest) body ...) 101 | (let ((var val)) 102 | (unless var 103 | (let rest 104 | body ...)))])) 105 | 106 | (define-syntax if-not 107 | (syntax-rules () 108 | [(_ predicate consequent alternate) 109 | (if predicate alternate consequent)])) 110 | 111 | (define-syntax if-let 112 | (syntax-rules () 113 | [(_ ((var val) . rest) then else) 114 | (let ((var val)) 115 | (if var (let rest then) else))])) 116 | 117 | 118 | -------------------------------------------------------------------------------- /source/gui.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/gui/base 3 | racket/class 4 | racket/set 5 | "utils.rkt" 6 | "render.rkt" 7 | "game.rkt" 8 | "sound.rkt" 9 | "core.rkt") 10 | (provide w-canvas%) 11 | (define timer-interval (/ 1 60)) 12 | 13 | (define input-handler% 14 | (class object% 15 | (super-new) 16 | 17 | (define pressed (seteq)) 18 | 19 | (define/public (active-keys) pressed) 20 | 21 | (define/public (on-char ev) 22 | (let* ([press? (not (eq? 'release (send ev get-key-code)))] 23 | [kc (if press? (send ev get-key-code) (send ev get-key-release-code))]) 24 | (when-let ((key (interpret-key kc))) 25 | (if press? 26 | (set! pressed (set-add pressed key)) 27 | (set! pressed (set-remove pressed key)))))) 28 | 29 | (define (interpret-key kc) 30 | (case kc 31 | [(up #\w #\W) 'up] 32 | [(down #\s #\S) 'down] 33 | [(right #\d #\D) 'right] 34 | [(left #\a #\A) 'left] 35 | [(space #\space) 'use] 36 | [(#\g #\G) 'godmode] 37 | [(escape #\q #\Q) 'restart] 38 | )) 39 | )) 40 | 41 | 42 | (define w-canvas% 43 | (class canvas% 44 | (super-new) 45 | (inherit get-dc get-client-size refresh get-parent) 46 | (send* (get-dc) 47 | (set-scale *scale* *scale*) 48 | (set-background "black")) 49 | 50 | (define input-handler (make-object input-handler%)) 51 | (define game (make-object game%)) 52 | (define millis (current-inexact-milliseconds)) 53 | (define frames 0) 54 | (define game-over? #f) 55 | (define running? #f) 56 | (define timer #f) 57 | (define scale *scale*) 58 | 59 | (define/override (on-size w h) 60 | (let* ((wsc (/ w PIX_WIDE)) 61 | (hsc (/ h PIX_HIGH)) 62 | (sc (min wsc hsc)) 63 | (ww (* sc PIX_WIDE)) 64 | (hh (* sc PIX_HIGH))) 65 | (set! scale sc) 66 | (send (get-dc) set-scale sc sc) 67 | ;(send (get-parent) resize ww hh) 68 | )) 69 | 70 | 71 | (define/override (on-char ev) 72 | (send input-handler on-char ev) 73 | (when (or (and game-over? 74 | (set-member? (send input-handler active-keys) 'use)) 75 | (set-member? (send input-handler active-keys) 'restart)) 76 | (set! game-over? #f) 77 | (set! game (make-object game%)))) 78 | 79 | (define/public (run) 80 | 81 | (refresh) 82 | ) 83 | 84 | (define/public (start) 85 | (unless running? 86 | (set! running? #t) 87 | (unless timer 88 | (set! timer 89 | (new timer% [interval (inexact->exact 90 | (floor (* 1000.0 timer-interval)))] 91 | [notify-callback 92 | (λ _ (send this run))]))))) 93 | 94 | (define/public (stop) 95 | (when running? 96 | (set! running? #f) 97 | (when timer 98 | (send timer stop)))) 99 | 100 | (define/override (on-paint) 101 | (when (>= (- (current-inexact-milliseconds) millis) 3000.0) 102 | (log-debug (format "~a fps~n" (floor* frames 3))) 103 | (set! millis (current-inexact-milliseconds)) 104 | (set! frames 0)) 105 | 106 | (unless game-over? 107 | (send game tick (send input-handler active-keys)) 108 | (when (send game over?) 109 | (play-effect 'game-over) 110 | (set! game-over? #t))) 111 | 112 | (let-values (((w h) (get-client-size))) 113 | (render game (get-dc) 114 | (floor* w *scale*) 115 | (floor* h *scale*))) 116 | 117 | (play-effects (send game get-sounds)) 118 | (set! frames (add1 frames))) 119 | 120 | 121 | )) 122 | -------------------------------------------------------------------------------- /source/render.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/gui 2 | 3 | (require "utils.rkt" 4 | racket/runtime-path 5 | racket/require 6 | racket/flonum 7 | racket/fixnum 8 | #;(filtered-in 9 | (λ (name) (regexp-replace #rx"unsafe-" name "")) 10 | racket/unsafe/ops)) 11 | (provide render) 12 | (define square-hash 13 | #hasheq((player-r . (0 . 2)) 14 | (player-d . (0 . 3)) 15 | (player-u . (0 . 4)) 16 | (player-l . (0 . 5)) 17 | (test . (0 . 0)) 18 | (boulder . (1 . 0)) 19 | (grass . (2 . 0)) 20 | (dirt . (3 . 0)) 21 | (sand . (4 . 0)) 22 | (screen-on . (5 . 0)) 23 | (screen-off . (6 . 0)) 24 | (floor-on . (7 . 0)) 25 | (yes-f . (7 . 0)) 26 | (floor-off . (8 . 0)) 27 | (no-f . (8 . 0)) 28 | (lava . (0 . 1)) 29 | (teleport . (1 . 1)) 30 | (flor . (2 . 1)) 31 | (wall . (3 . 1)) 32 | (door-lr-open . (4 . 1)) 33 | (door-lr-close . (6 . 1)) 34 | (door-ud-open . (4 . 2)) 35 | (door-ud-close . (4 . 4)))) 36 | (define anim-hash 37 | #hasheq((right . #((0 . 2) (1 . 2) (2 . 2) (3 . 2))) 38 | (down . #((0 . 3) (1 . 3) (2 . 3) (3 . 3))) 39 | (up . #((0 . 4) (1 . 4) (2 . 4) (3 . 4))) 40 | (left . #((0 . 5) (1 . 5) (2 . 5) (3 . 5))) 41 | (zap . #((0 . 6) (1 . 6) (2 . 6) (3 . 6) 42 | (4 . 6) (5 . 6) (6 . 6))))) 43 | (define square-size 16) 44 | (define square-size.0 16.0) 45 | (define squares 46 | (for/hasheq (((k v) (in-hash square-hash))) 47 | (values k (cons (fx* square-size (car v)) 48 | (fx* square-size (cdr v)))))) 49 | 50 | (define-runtime-path image-location "../res/img.png") 51 | (define the-bitmap (read-bitmap image-location 'png/alpha)) 52 | (define anim-size 16) 53 | 54 | (define animations 55 | (for/hasheq (((k v) (in-hash anim-hash))) 56 | (values k (for/vector ((c (in-vector v))) 57 | (cons (fx* anim-size (car c)) 58 | (fx* anim-size (cdr c))))))) 59 | 60 | 61 | 62 | (define (draw-animation which step x y dc) 63 | (let ((pt (vector-ref (hash-ref animations which) step))) 64 | (send dc draw-bitmap-section the-bitmap x y 65 | (car pt) (cdr pt) anim-size anim-size))) 66 | 67 | (define (draw-game-over xo yo dc) 68 | (let-values (((sx sy) (send dc get-scale))) 69 | (send dc set-scale 8 8) 70 | (send dc draw-bitmap-section the-bitmap 71 | (fx+ xo 18) (fx+ yo 12) (fx* 16 7) 16 64 16) 72 | (send dc draw-bitmap-section the-bitmap 73 | (fx+ xo 18) (fx+ yo 36) (fx* 16 12) 16 64 16) 74 | (send dc set-scale sx sy))) 75 | 76 | (define (render game dc w h) 77 | (let ((level (send game get-level)) 78 | (dyn (send game get-dynamic))) 79 | (send dc clear) 80 | (let* ((ghei (fx* square-size (vector-length level))) 81 | (gwid (fx* square-size (vector-length (vector-ref level 0)))) 82 | (wdif (fx- h ghei)) 83 | (hdif (fx- w ghei))) 84 | (when (or (negative? wdif) (negative? hdif)) 85 | (printf "uh oh! screen is too small: game-width: ~a game-height: ~a w: ~a h: ~a~n" 86 | ghei gwid w h)) 87 | (let ((x-offset (fxmin (fxquotient wdif 2) 0)) 88 | (y-offset (fxmin (fxquotient hdif 2) 0))) 89 | 90 | ;; draw the tiles 91 | (for ([row (in-vector level)] 92 | [yi (in-range 0 (fx* square-size (vector-length level)) square-size)] 93 | #:when #t 94 | [spot (in-vector row)] 95 | [xi (in-range 0 (fx* square-size (vector-length row)) square-size)]) 96 | (let ((pt (hash-ref 97 | squares spot 98 | (λ (e) (printf "draws: not-found: ~a~n" e) '(0 . 0))))) 99 | (send dc draw-bitmap-section the-bitmap 100 | (fx+ x-offset xi) (fx+ y-offset yi) 101 | (car pt) (cdr pt) 102 | square-size square-size))) 103 | 104 | ;; draw the animations 105 | (for ([e (in-list dyn)]) 106 | (let-values (((x y name step) (send e get-draw-info))) 107 | (draw-animation name step 108 | (fx+ x-offset (fl->fx (flfloor (fl* square-size.0 x)))) 109 | (fx+ y-offset (fl->fx (flfloor (fl* square-size.0 y)))) 110 | dc))) 111 | (when (send game over?) (draw-game-over x-offset y-offset dc)))))) 112 | 113 | 114 | 115 | -------------------------------------------------------------------------------- /source/player.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class "utils.rkt") 3 | (provide player%) 4 | (define player% 5 | (class object% 6 | (super-new) 7 | (init-field x y direction game) 8 | (field [step 0] 9 | [tilex -1] 10 | [tiley -1] 11 | [dead? #f]) 12 | 13 | (define motion 0.0) 14 | ; private field for calculating the current part of the animation 15 | ; (should the player even know about this?) 16 | 17 | (define (on-move x y) 18 | (let ((tx (inexact->exact (floor (+ 0.5 x)))) 19 | (ty (inexact->exact (floor (+ 0.5 y))))) 20 | (unless (and (= tx tilex) (= ty tiley)) 21 | (set! tilex tx) 22 | (set! tiley ty) 23 | (on-tile-change tilex tiley)))) 24 | 25 | (on-move x y) 26 | 27 | ; constant 28 | (define speed 0.06) 29 | (define friction 0.10) 30 | (define hit-right 0.00) 31 | (define hit-left -0.05) 32 | (define hit-foot 0.46) 33 | (define hit-head -0.30) 34 | 35 | 36 | (define/public (get-loc) (cons tilex tiley)) 37 | (define/public (get-dir) direction) 38 | 39 | (define/public (set-x nx) (set! x nx) (on-move x y)) 40 | (define/public (set-y ny) (set! y ny) (on-move x y)) 41 | (define/public (set-pos nx ny) (set! x nx) (set! y ny) (on-move x y)) 42 | 43 | (define/public (get-x) x) 44 | (define/public (get-y) y) 45 | (define/public (get-pos) (cons x y)) 46 | 47 | (define/public (get-step) (modulo (inexact->exact (floor step)) 4)) 48 | (define/public (step!) (set! step (modulo (add1 step) 4))) 49 | 50 | (define (maybe-step) (when (> motion 0.5) (step!) (set! motion 0.0))) 51 | (define (reset-step) (set! step 0)) 52 | (define (die) 53 | (unless (send game god-mode?) 54 | (set! dead? #t) (on-death))) 55 | 56 | (define (reorient u d l r) 57 | (let ((last direction)) 58 | (unless (or (not (or u d l r)) (and u d l r)) 59 | (when (not (eq? l r)) 60 | (set! direction (if r 'right 'left))) 61 | (when (not (eq? u d)) 62 | (set! direction (if d 'down 'up)))) 63 | (if (eq? direction last) 64 | (maybe-step) 65 | (reset-step)))) 66 | 67 | (define (on-tile-change x y) (send game tile-changed x y)) 68 | (define (on-death) (send game lose)) 69 | 70 | (define move 71 | (let ((xa 0.0) (ya 0.0)) 72 | (define (do-move) 73 | (let ((ys (floor* (add1 (abs (* xa 100))))) 74 | (xs (floor* (add1 (abs (* ya 100)))))) 75 | (let loop ([i xs]) 76 | (when (> i 0) 77 | (let ((nx (+ (get-x) (* xa (/ i xs))))) 78 | (if (check-spot nx y) 79 | (set! x nx) 80 | (begin (set! xa 0.0) 81 | (loop (sub1 i))))))) 82 | (let loop ([i ys]) 83 | (when (> i 0) 84 | (let* ((ny (+ y (* ya (/ i ys))))) 85 | (if (check-spot x ny) 86 | (set! y ny) 87 | (begin (set! ya 0.0) 88 | (loop (sub1 i))))))))) 89 | (λ (xp yp) 90 | (dec! xa (* xp speed)) 91 | (dec! ya (* yp speed)) 92 | (do-move) 93 | (set! xa (* xa friction)) 94 | (set! ya (* ya friction)) 95 | (on-move x y)))) 96 | 97 | (define/public (tick u d l r) 98 | (if (or (not (or u d l r)) (and u d l r)) 99 | (set! step 0) 100 | (let* ([xm (+ (if l 1.0 0.0) (if r -1.0 0.0))] 101 | [ym (+ (if u 1.0 0.0) (if d -1.0 0.0))] 102 | [dist^2 (+ (* xm xm) (* ym ym))] 103 | [dist (if (> 0.0 dist^2) (sqrt dist^2) 1.0)] 104 | [x-norm (/ xm dist)] [y-norm (/ ym dist)]) 105 | (inc! motion (* speed (sqrt (+ (* x-norm x-norm) (* y-norm y-norm))))) 106 | (reorient u d l r) 107 | (move x-norm y-norm)))) 108 | 109 | (define/public (check-spot [xx x] [yy y]) 110 | (let ((x0 (inexact->exact (floor (+ xx 0.5 (- hit-left))))) 111 | (x1 (inexact->exact (floor (+ xx 0.5 hit-right)))) 112 | (y0 (inexact->exact (floor (+ yy 0.5 (- hit-head))))) 113 | (y1 (inexact->exact (floor (+ yy 0.5 hit-foot))))) 114 | (when (check-deadly x0 y0 x1 y1) 115 | (die)) 116 | (and (not dead?) 117 | (not (send game blocked? x0 y0)) 118 | (not (send game blocked? x1 y0)) 119 | (not (send game blocked? x0 y1)) 120 | (not (send game blocked? x1 y1))) 121 | )) 122 | (define (check-deadly x0 y0 x1 y1) 123 | (or (send game deadly? x0 y0) 124 | (send game deadly? x1 y0) 125 | (send game deadly? x0 y1) 126 | (send game deadly? x1 y1))) 127 | 128 | (define/public (get-draw-info) (values (exact->inexact x) (exact->inexact y) direction step)) 129 | 130 | )) 131 | -------------------------------------------------------------------------------- /source/tile.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "utils.rkt") 3 | (provide (all-defined-out)) 4 | (struct tile (x y deadly? solid? usable?) #:transparent #:mutable) 5 | 6 | (define set-tile-pos! 7 | (case-lambda 8 | [(tile p) (set-tile-pos! tile (car p) (cdr p))] 9 | [(tile x y) (set-tile-x! tile x) (set-tile-y! tile y)])) 10 | 11 | 12 | (define (tile-pos tile) 13 | (cons (tile-x tile) 14 | (tile-y tile))) 15 | 16 | (define (tile-active? tile) 17 | (and (> 0 (tile-x tile)) 18 | (> 0 (tile-y tile)))) 19 | 20 | (define (deactivate-tile! tile) 21 | (set-tile-pos! tile -1 -1)) 22 | 23 | (struct grass tile () #:transparent #:mutable) 24 | (struct flor tile () #:transparent #:mutable) 25 | (struct yes-f tile () #:transparent #:mutable);; todo 26 | (struct no-f tile () #:transparent #:mutable);; these, but better 27 | (struct dirt tile () #:transparent #:mutable) 28 | (struct lava tile () #:transparent #:mutable) 29 | (struct wall tile () #:transparent #:mutable) 30 | (struct test tile () #:transparent #:mutable) 31 | (struct sand tile () #:transparent #:mutable) 32 | 33 | (struct screen tile (on? controls) #:transparent #:mutable) 34 | (struct teleport tile (dest) #:transparent #:mutable) 35 | (struct door tile (dir locked?) #:transparent #:mutable) ; dir is either 'ud or 'lr 36 | (define (init-plain ctor) 37 | (λ ([p (cons -1 -1)]) (ctor (car p) (cdr p) #f #f #f))) 38 | (define init-grass (init-plain grass)) 39 | (define init-flor (init-plain flor)) 40 | (define init-sand (init-plain sand)) 41 | (define init-dirt (init-plain dirt)) 42 | (define init-test (init-plain test)) 43 | (define init-yes-f (init-plain yes-f)) 44 | (define init-no-f (init-plain no-f)) 45 | 46 | ;(define (init-grass [p (cons -1 -1)]) (grass (car p) (cdr p) #f #f #f)) 47 | ;(define (init-flor [p (cons -1 -1)]) (flor (car p) (cdr p) #f #f #f)) 48 | 49 | ;(define (init-flor [p (cons -1 -1)]) (flor (car p) (cdr p) #f #f #f)) 50 | ;(define (init-dirt [p (cons -1 -1)]) (dirt (car p) (cdr p) #f #f #f)) 51 | (define (init-lava [p (cons -1 -1)]) (lava (car p) (cdr p) #t #f #f)) 52 | (define (init-wall [p (cons -1 -1)]) (wall (car p) (cdr p) #f #t #f)) 53 | ;(define (init-test [p (cons -1 -1)]) (test (car p) (cdr p) #f #f #f)) 54 | ;(define (init-sand [p (cons -1 -1)]) (sand (car p) (cdr p) #f #f #f)) 55 | (define (init-teleport [p (cons -1 -1)]) (teleport (car p) (cdr p) #f #f #t 'none)) 56 | (define (init-screen on? [p (cons -1 -1)]) (screen (car p) (cdr p) #f #t #t on? 'none)) 57 | (define (init-door dir [p (cons -1 -1)] [open? #f] [locked? #f]) 58 | (door (car p) (cdr p) #f (not open?) #t dir locked?)) 59 | 60 | (define (use-screen s) 61 | (if (screen-on? s) 62 | (screen-off s) 63 | (screen-on s))) 64 | 65 | 66 | (define (screen-off s) 67 | (set-screen-on?! s #f)) 68 | (define (screen-on s) 69 | (set-screen-on?! s #t)) 70 | 71 | (define (use-door d) 72 | (let ((open? (door-open? d))) 73 | (if open? 74 | (open-door d) 75 | (close-door d)) 76 | (not (boolean=? open? (door-open? d))))) ; return true if it changed state. 77 | 78 | (define (open-door d) 79 | (unless (door-locked? d) 80 | (set-tile-solid?! d #f))) 81 | 82 | (define (door-open? d) 83 | (tile-solid? d)) 84 | 85 | (define (close-door d) 86 | (when (door-locked? d) 87 | (set-door-locked?! d #f)) 88 | (set-tile-solid?! d #t)) 89 | 90 | (define (struct-string s) 91 | (cadr 92 | (regexp-match 93 | #rx"^struct:(.*)$" 94 | (symbol->string (vector-ref (struct->vector s) 0))))) 95 | 96 | (define (struct-name s) 97 | (string->symbol (struct-string s))) 98 | 99 | 100 | (define (make-teleport-pair) 101 | (letrec ([ta (teleport -1 -1 #f #f #t tb)] 102 | [tb (teleport -1 -1 #f #f #t ta)]) 103 | (values ta tb))) 104 | 105 | (define (place-tile tile level x y) 106 | (when (tile? (vref level y x)) 107 | (deactivate-tile! (vref level y x))) 108 | (set-tile-pos! tile x y) 109 | (vset! level tile y x)) 110 | 111 | (define (create-and-place-teleport-pairs tele-as tele-bs level) ; list of posns, should return list of teleports 112 | (unless (= (length tele-as) (length tele-bs)) 113 | (error 'place-teleports "length of as and bs should be the same, given ~a and ~a" tele-as tele-bs)) 114 | (map 115 | (λ (a b) 116 | (let-values ([(ta tb) (make-teleport-pair)]) 117 | (place-tile ta level (car a) (cdr a)) 118 | (place-tile tb level (car b) (cdr b)) 119 | (cons ta tb))) 120 | tele-as tele-bs)) 121 | 122 | 123 | 124 | (define (create-and-place-teleport-list ts [cycle? #f]) 125 | (let ((first-tele (init-teleport (car ts)))) 126 | (let loop ([posns (cdr ts)] [teles `(,first-tele)]) 127 | (cond [(null? posns) (when cycle? (set-teleport-dest! (car teles) first-tele)) teles] 128 | [else (let ([this-tele (init-teleport (car posns))] [last-tele (car teles)]) 129 | (set-teleport-dest! last-tele this-tele) 130 | (loop (cdr posns) (cons this-tele teles)))])))) 131 | 132 | (define (use-teleport t) ; returns new location, or #f to indicate that nothing should happen 133 | (and (tile-active? t) 134 | (let ((td (teleport-dest t))) 135 | (if (eq? td 'none) #f (tile-pos td))))) 136 | -------------------------------------------------------------------------------- /source/game.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/class 3 | racket/set 4 | "utils.rkt" 5 | "tile.rkt" 6 | "level.rkt" 7 | "player.rkt") 8 | (provide game%) 9 | 10 | 11 | 12 | 13 | 14 | 15 | (define zap 16 | (class object% 17 | (super-new) 18 | (init x y) 19 | (define step 0) 20 | (define xx (exact->inexact x)) 21 | (define yy (exact->inexact y)) 22 | (define/public (get-draw-info) (values xx yy 'zap step)) 23 | (define/public (step!) (set! step (add1 step))))) 24 | 25 | (define game% 26 | (class object% 27 | (super-new) 28 | (define player (make-object player% -1 -1 'right this)) 29 | (define entities (list player)) 30 | (define teleporting? #f) 31 | (define teleport-count 0) 32 | (define teleport-to #f) 33 | (define game-over? #f) 34 | 35 | (define god? #f) 36 | (define sounds '()) 37 | (define current-level 'none) 38 | 39 | 40 | 41 | (define/public (get-dynamic) entities) 42 | (define/public (get-sounds) sounds) 43 | 44 | (define/public (deadly? x y) 45 | (with-handlers ([exn:fail? (λ _ #f)]) 46 | (if (not (in-range x y)) 47 | #f 48 | (tile-deadly? (vref (level-data current-level) y x))))) 49 | 50 | (define/public (blocked? x y) 51 | (with-handlers ([exn:fail? (λ _ #f)]) ; too close to end to do this better 52 | (if (not (in-range x y)) 53 | #f 54 | (tile-solid? (vref (level-data current-level) y x))))) 55 | (define/public (god-mode?) god?) 56 | (define/public (set-level which-level [init? #f]) 57 | (set! current-level (which-level)) 58 | (if init? 59 | (push! sounds 'game-start) 60 | (push! sounds 'solve)) 61 | (send player set-pos (car (level-spawn current-level)) (cdr (level-spawn current-level)))) 62 | (define/public (get-tile x y) (vector-ref (vector-ref (level-data current-level) y) x)) 63 | (define/public (get-entities) entities) 64 | (define/public (get-level) (make-exportable current-level)) 65 | (define/public (get-player) player) 66 | (define/public (over?) game-over?) 67 | (define/public (lose) (set! game-over? #t)) 68 | 69 | (define (check-flags keys) 70 | (for ([k keys]) 71 | (case k 72 | [(godmode) (set! god? #t)]))) 73 | 74 | (define (clear-sounds) (set! sounds '())) 75 | 76 | (define/public (tick keys) 77 | (clear-sounds) 78 | (when (eq? current-level 'none) 79 | (set-level level:start #t)) 80 | (check-flags keys) 81 | (do-tick keys)) 82 | 83 | (define/public (tile-changed tx ty) 84 | (cond [(list? (level-exits current-level)) 85 | (let ((change-level? (alist-get (cons tx ty) (level-exits current-level)))) 86 | (when change-level? (set-level change-level?)))] 87 | [(symbol? (level-exits current-level)) 88 | (case (level-exits current-level) 89 | [(wrap-around) (when (or (= tx -1) (= ty -1) (= ty 6) (= tx 10)) 90 | (call-with-values (λ () (wrap-around (clamp tx 0 9) (clamp ty 0 5))) 91 | (λ (x y) (send player set-pos x y))))])]) 92 | 93 | 94 | (send player check-spot)) 95 | 96 | (define (usable? p) 97 | (if (not (in-range? (car p) (cdr p))) 98 | #f 99 | (tile-usable? (vref (level-data current-level) (cdr p) (car p))))) 100 | 101 | (define (use) 102 | (let* ([p (send player get-loc)] 103 | [d (send player get-dir)] 104 | [looking (pt+ (get-delta d) p)] 105 | [active (cond [(usable? p) 106 | (vref (level-data current-level) (cdr p) (car p))] 107 | [(usable? looking) 108 | (vref (level-data current-level) 109 | (cdr looking) (car looking))] 110 | [else #f])]) 111 | (when active 112 | (use-tile active)))) 113 | 114 | (define (in-range? x y) 115 | (and (>= x 0) (>= y 0) 116 | (< y (vector-length (level-data current-level))) 117 | (< x (vector-length (vector-ref (level-data current-level) 0))))) 118 | 119 | (define (screen-alert t v) 120 | (cond [(procedure? t) 121 | (t (level-data current-level) this)] 122 | [(screen? t) 123 | (set-screen-on?! t v)] 124 | [(door? t) 125 | (set-door-locked?! t (not (door-locked? t)))])) 126 | 127 | (define/public (teleport-player tile) 128 | (unless teleporting? 129 | (let ((t (send player get-loc))) 130 | (set! teleporting? #t) 131 | (set! teleport-count 0) 132 | (set! teleport-to tile) 133 | (push! entities (make-object zap (car t) (cdr t)))))) 134 | 135 | (define (use-tile t) 136 | (cond 137 | [(screen? t) 138 | (push! sounds 'screen) 139 | (use-screen t) 140 | (screen-alert (screen-controls t) (screen-on? t))] 141 | [(teleport? t) 142 | (push! sounds 'zap) 143 | (teleport-player (teleport-dest t))] 144 | [(door? t) 145 | (if (use-door t) 146 | (push! sounds 'door) 147 | (push! sounds 'locked))])) 148 | 149 | 150 | (define (continue-teleporting) 151 | (cond [(>= teleport-count 6);done teleporting 152 | (set! teleporting? #f) 153 | (send player set-pos 154 | (tile-x teleport-to) 155 | (tile-y teleport-to)) 156 | (set! teleport-count 0) 157 | (set! entities (list player))] 158 | [(= teleport-count 4) ; player hidden, stop drawing him. 159 | (set! entities (list (car entities))) 160 | (set! teleport-count (add1 teleport-count)) 161 | (send (car entities) step!)] 162 | [else (send (car entities) step!) 163 | (set! teleport-count (add1 teleport-count))])) 164 | (define do-tick 165 | (let ((using? #f)) ; prevents use from repeatedly firing 166 | (λ (keys) 167 | (cond [teleporting? (continue-teleporting)] 168 | [(set-member? keys 'use) 169 | (unless using? 170 | (set! using? #t) 171 | (use))] 172 | [else (set! using? #f) 173 | (send player tick 174 | (set-member? keys 'up) 175 | (set-member? keys 'down) 176 | (set-member? keys 'left) 177 | (set-member? keys 'right))])))) 178 | )) 179 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. -------------------------------------------------------------------------------- /source/level.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/list racket/class "utils.rkt" "tile.rkt") 3 | (provide (all-defined-out)) 4 | (struct level (data spawn exits) #:transparent #:mutable) 5 | 6 | 7 | (define (make-level sh spawn exits) 8 | (let* ([teles '()] 9 | [screens '()] 10 | [v (for/vector ([row (in-vector sh)] [y (in-naturals)]) 11 | (for/vector ([p (in-vector row)][x (in-naturals)]) 12 | (cond [(pair? p) 13 | (case (car p) 14 | [(t) ; teleport contains the position of its destination. 15 | (let ((tt (init-teleport (cons x y)))) 16 | (push! teles (cons tt (cdr p))) 17 | tt)] 18 | [(1 0) ; screen contains the position of a thing it activates 19 | (let ((ss (init-screen (eq? (car p) 1) (cons x y)))) 20 | (push! screens (cons ss (cdr p))) 21 | ss)] 22 | [(> v) ; door contains open and locked 23 | (init-door (if (eq? (car p) '>) 'lr 'ud) (cons x y) (second p) (third p))])] 24 | [else 25 | (case p 26 | [(g) (init-grass (cons x y))] 27 | [(f) (init-flor (cons x y))] 28 | [(d) (init-dirt (cons x y))] 29 | [(l) (init-lava (cons x y))] 30 | [(w) (init-wall (cons x y))] 31 | [(y) (init-yes-f (cons x y))] 32 | [(n) (init-no-f (cons x y))] 33 | [(s) (init-sand (cons x y))])])))]) 34 | (for-each (λ (t) (set-teleport-dest! (car t) (vref v (cddr t) (cadr t)))) teles) 35 | (for-each (λ (s) (set-screen-controls! (car s) (if (procedure? (cdr s)) (cdr s) 36 | (vref v (cddr s) (cadr s))))) screens) 37 | (level v spawn exits))) 38 | 39 | (define (startlevel) 40 | #(#(w (0 7 . 5) w w w w w w w w) 41 | #(w f f f w f f f f w) 42 | #(w f (t 5 . 4) f w f w f f w) 43 | #(w f f f w f (> #f #f) f f w) 44 | #(w f f f w (t 2 . 2) w f f w) 45 | #(w w w w w w w (v #f #t) w w))) 46 | 47 | 48 | (define (ff level . _) 49 | (let ([tele (vref level 4 1)] 50 | [dst0 (vref level 1 4)] 51 | [dst1 (vref level 4 8)]) 52 | (if (eq? (teleport-dest tele) dst0) 53 | (set-teleport-dest! tele dst1) 54 | (set-teleport-dest! tele dst0)))) 55 | 56 | 57 | (define (lavalevel) 58 | (let ((ll 59 | (vector 60 | (vector 'w 'w 0 'w 'w 'w 'w '(v #f #t) 'w 'w) 61 | (vector 'w 'l 'f 'l 'f 'l 'l 'f 'l 'w) 62 | (vector 'w 'l 'f 'l 'l 'l 'f 'f 'l 'w) 63 | (vector 'w 'l 'f 'f 'f 'f 'f 'w 'l 'w) 64 | (vector 'w '(t 4 . 1) 'f 'l 'l 'l 'l 'l 'f '(> #f #f)) 65 | (vector 'w 'w 'w 'w 'w 'w 'w 'w 'w 'w)))) 66 | (vset! ll 0 2 (cons 0 ff)) 67 | ll)) 68 | (define (make-exportable level) 69 | (for/vector ((j (in-vector (level-data level)))) 70 | (for/vector ((i (in-vector j))) 71 | (let ((sn (struct-name i))) 72 | (case sn 73 | [(screen) (if (screen-on? i) 'screen-on 'screen-off)] 74 | [(door) (let ((d (door-dir i)) 75 | (o (if (door-open? i) "open" "close"))) 76 | (string->symbol (string-append "door-" (symbol->string d) "-" o)))] 77 | [else sn]))))) 78 | 79 | (define (leveldata-map f data) 80 | (for/vector ([y (in-vector data)]) 81 | (for/vector ([x (in-vector y)]) 82 | (f x)))) 83 | 84 | (define (level-map f l) (struct-copy level l [data (leveldata-map f (level-data l))])) 85 | 86 | (define (leveldata-for-each f d) 87 | (for ([row (in-vector d)][y (in-naturals)] #:when #t 88 | [p (in-vector row)][x (in-naturals)]) 89 | (f d x y))) 90 | 91 | (define (level-count f l) (leveldata-count f (level-data l))) 92 | 93 | (define (leveldata-count f d) 94 | (for*/fold ([i 0]) 95 | ([row (in-vector d)] 96 | [p (in-vector row)] 97 | #:when (f p)) 98 | (add1 i))) 99 | 100 | (define (screens-on+off level) 101 | (for*/fold ([on 0] [off 0]) 102 | ([row (in-vector level)][p (in-vector row)] #:when (screen? p)) 103 | (if (screen-on? p) 104 | (values (add1 on) off) 105 | (values on (add1 off))))) 106 | 107 | (define (on+off-sc-posns level) 108 | (for*/fold ([ons '()] [offs '()]) 109 | ([row (in-vector level)] [p (in-vector row)] #:when (screen? p)) 110 | (if (screen-on? p) 111 | (values (cons (cons (tile-x p) (tile-y p)) ons) offs) 112 | (values ons (cons (cons (tile-x p) (tile-y p)) offs))))) 113 | 114 | (define (screens-on level) (let-values ([(on off) (screens-on+off level)]) on)) 115 | (define (screens-off level) (let-values ([(on off) (screens-on+off level)]) off)) 116 | 117 | (define (lightf x y) 118 | (λ (level _ [init? #f] . rst) 119 | (let ((nbors (filter screen? (cond [(or (= x 0) (= x 9)) (list (vref level (+ y 1) x) (vref level (- y 1) x))] 120 | [(or (= y 0) (= y 5)) (list (vref level y (+ x 1)) (vref level y (- x 1)))] 121 | [else '()])))) 122 | (for-each (λ (s) (set-screen-on?! s (not (screen-on? s)))) nbors)) 123 | (let-values ([(on off) (screens-on+off level)] 124 | [(ons offs) (on+off-sc-posns level)]) 125 | (unless init? 126 | (cond [(= 0 on); y'lost. 127 | (leveldata-for-each 128 | (λ (ld x y) 129 | (when (random-boolean) 130 | (vset! ld y x (init-lava)))) level)] 131 | [(= 0 off) (vset! level 2 9 (init-flor))] 132 | ))))) 133 | 134 | (define (lightsout) 135 | (build-vector 136 | 6 137 | (λ (y) 138 | (build-vector 139 | 10 140 | (λ (x) 141 | (cond [(not (or (= x 0) (= y 0) (= x 9) (= y 5))) 'f] 142 | [(or (and (= x 0) (= y 0)) 143 | (and (= x 0) (= y 5)) 144 | (and (= x 9) (= y 0)) 145 | (and (= x 9) (= y 5))) 'w] 146 | [else 147 | (cons 1 (lightf x y))])))))) 148 | 149 | 150 | (define (scramble lo) 151 | (let ([l (shuffle 152 | (for*/list 153 | ([row (in-vector (level-data lo))] 154 | [p (in-vector row)] #:when (screen? p)) 155 | p))]) 156 | (for ([i (in-range 15)]) 157 | (let ((s (random-element l))) 158 | (use-screen s) 159 | ((screen-controls s) (level-data lo) #t #t)))) 160 | lo) 161 | 162 | (define (emptylevel) 163 | #(#(w w w w w w w w w w) 164 | #(w f f f f f f f f w) 165 | #(w f f f f f f f f w) 166 | #(w f f f f f f f f w) 167 | #(w f f f f f f f f w) 168 | #(w w w w w w w w w w))) 169 | 170 | (define (mzlevel) 171 | #(#(w w w w(v #f #t) w w w w w) 172 | #(w d d d f f g g g w) 173 | #((> #f #t) d d d f f g g g w) 174 | #(w d d d f f g g g(> #f #t)) 175 | #(w d d d f f g g g w) 176 | #(w w w w(v #t #f) w w w w w))) 177 | (define (code-level) 178 | #(#(w w w w(v #f #t) w w w w w) 179 | #(f f f w f f w f f f) 180 | #(w w w w f f w w w w) 181 | #(w f f f f f f f f w) 182 | #(w y n n y n y y n w) 183 | #(w 0 0 0 0 0 0 0 0 w) ; replace this one 184 | )) 185 | (define (INFINITE-GREEN-PASTURES) 186 | #(#(d d d g g d d g g g) 187 | #(g d g g g d g d g g) 188 | #(g d g g g d d g g g) 189 | #(g g d d d g g d d d) 190 | #(g g d g d g g d g d) 191 | #(g g d d d g g d d d))) 192 | (define (mk-igp) 193 | (make-level (INFINITE-GREEN-PASTURES) (cons 1 1) 'wrap-around)) 194 | 195 | 196 | 197 | 198 | (define (funcvec) 199 | (let () 200 | (define solution '(0 1 1 0 1 0 0 1)) 201 | (define failure '(1 0 0 1 0 1 1 0)) 202 | (define (get-screens ld) (build-list 8 (λ (p) (vref ld 5 (add1 p))))) 203 | (define (make-state=? s) (λ (ld) (equal? s (map (λ (s) (if (screen-on? s) 1 0)) (get-screens ld))))) 204 | (define solved? (make-state=? solution)) 205 | (define failed? (make-state=? failure)) 206 | (define (permute-wrong ld) 207 | (let ([w (map = solution (map (λ (s) (if (screen-on? s) 1 0)) (get-screens ld)))]) 208 | (for ([p (in-list w)] [x (in-range 1 9)]) 209 | (vset! ld 4 x (if p (init-yes-f)(init-no-f)))))) 210 | (define (check-ld ld game) 211 | (cond [(solved? ld) (send game teleport-player (vref ld 1 7))] 212 | [(failed? ld) (send game teleport-player (vref ld 1 2))] 213 | )(permute-wrong ld)) 214 | (define (i-screen x) 215 | (let ((s (init-screen #f (cons x 5)))) 216 | (set-screen-controls! s (λ (ld game . _) (check-ld ld game))) 217 | s)) 218 | (build-vector 10 (λ (x) (if (or (= x 0) (= x 9)) (init-wall) (i-screen x)))))) 219 | ; todo: better datastructure for representing levels 220 | ; directed graph? 221 | 222 | 223 | 224 | (define-values (level:lava level:start level:lights-out level:maze level:code) 225 | (letrec ((lv (λ () (make-level (lavalevel) (cons 7 1) `(((7 . -1) . ,st) ((10 . 4) . ,lo))))) 226 | (st (λ () (make-level (startlevel) (cons 7 3) `(((7 . 5) . ,lv))))) 227 | (mz (λ () (make-level (mzlevel) (cons 1 2) `(((4 . 6) . ,cl))))) 228 | (cl (λ () (let ((l (make-level (code-level) 229 | (cons 4 1) 230 | `(((-1 . 1) . ,mk-igp) ((10 . 1) . ,mk-igp))))) 231 | (vector-set! (level-data l) 5 (funcvec)) l) )) 232 | (lo (λ () (scramble (make-level (lightsout) (cons 1 1) `(((10 . 2) . ,mz))))))) 233 | (values lv st lo mz cl))) 234 | 235 | 236 | 237 | --------------------------------------------------------------------------------